Theory Set_without_equal
theory Set_without_equal
imports Main
begin
text ‹
Adapt @{type "set"} code setup such that @{const "insert"},
@{const "union"}, and @{term "set_of_pred"} do not generate
sort constraint @{class equal}.
›
definition insert' :: "'a ⇒ 'a set ⇒ 'a set"
where "insert' = Set.insert"
definition union' :: "'a set ⇒ 'a set ⇒ 'a set"
where "union' A B = sup A B"
declare
insert'_def [symmetric, code_unfold]
union'_def [symmetric, code_unfold]
lemma insert'_code:
"insert' x (set xs) = set (x # xs)"
by (rule set_eqI) (simp add: insert'_def)
lemma union'_code:
"union' (set xs) (set ys) = set (xs @ ys)"
by (rule set_eqI) (simp add: union'_def fun_eq_iff)
declare
insert'_code [code]
union'_code [code]
text ‹Merge name spaces to avoid cyclic module dependencies›
code_identifier
code_module Set_without_equal ⇀
(SML) Set and (Haskell) Set and (OCaml) Set
end
Theory Set_Monad
theory Set_Monad
imports
Main
"HOL-Library.Monad_Syntax"
begin
lemma member_SUP:
"x ∈ ⋃(f ` A) = (SUP B∈A. (λx. x ∈ f B)) x"
by auto
abbreviation (input) "of_pred == Predicate.set_of_pred"
abbreviation (input) "of_seq == Predicate.set_of_seq"
lemmas bind_def = Set.bind_def
lemmas bind_bind = Set.bind_bind
lemmas empty_bind = Set.empty_bind
lemmas bind_const = Set.bind_const
lemmas member_of_pred = Predicate.member_set_of_pred
lemmas member_of_seq = Predicate.member_set_of_seq
definition single :: "'a ⇒ 'a set"
where "single a = {a}"
definition undefined :: "'a set"
where [simp]: "undefined = Collect HOL.undefined"
declare [[code abort: undefined]]
definition Undefined :: "unit ⇒ 'a set"
where "Undefined _ = Collect HOL.undefined"
declare [[code abort: Undefined]]
lemma undefined_code [code_unfold]:
"undefined = Undefined ()"
by (simp add: Undefined_def)
lemma bind_single [simp, code_unfold]:
"A ⤜ single = A"
by (simp add: bind_def single_def)
lemma single_bind [simp, code_unfold]:
"single a ⤜ B = B a"
by (simp add: bind_def single_def)
declare Set.empty_bind [code_unfold]
lemma member_single [simp]:
"x ∈ single a ⟷ x = a"
by (simp add: single_def)
lemma single_sup_simps [simp, code_unfold]:
shows single_sup: "sup (single a) A = insert a A"
and sup_single: "sup A (single a) = insert a A"
by (unfold set_eq_iff) auto
lemma single_code [code]:
"single a = set [a]"
by (simp add: set_eq_iff)
end
Theory JT_ICF
section ‹Adapting the Isabelle Collection Framework for Jinja Threads›
theory JT_ICF
imports Collections.CollectionsV1
begin
text ‹Hide stuff that may lead to confusions later›
hide_const (open) Array
hide_type (open) array
end
Theory Auxiliary
section ‹Auxiliary Definitions and Lemmata›
theory Auxiliary
imports
Complex_Main
"HOL-Library.Transitive_Closure_Table"
"HOL-Library.Predicate_Compile_Alternative_Defs"
"HOL-Library.Monad_Syntax"
"HOL-Library.Infinite_Set"
FinFun.FinFun
begin
unbundle finfun_syntax
lemma nat_add_max_le[simp]:
"((n::nat) + max i j ≤ m) = (n + i ≤ m ∧ n + j ≤ m)"
by arith
lemma Suc_add_max_le[simp]:
"(Suc(n + max i j) ≤ m) = (Suc(n + i) ≤ m ∧ Suc(n + j) ≤ m)"
by arith
lemma less_min_eq1:
"(a :: 'a :: order) < b ⟹ min a b = a"
by(auto simp add: min_def order_less_imp_le)
lemma less_min_eq2:
"(a :: 'a :: order) > b ⟹ min a b = b"
by(auto simp add: min_def order_less_imp_le)
no_notation floor ("⌊_⌋")
notation Some ("(⌊_⌋)")
declare
option.splits[split]
Let_def[simp]
subset_insertI2 [simp]
declare not_Cons_self [no_atp]
lemma Option_bind_eq_None_conv:
"x ⤜ y = None ⟷ x = None ∨ (∃x'. x = Some x' ∧ y x' = None)"
by(cases x) simp_all
lemma Option_bind_eq_Some_conv:
"x ⤜ y = Some z ⟷ (∃x'. x = Some x' ∧ y x' = Some z)"
by(cases x) simp_all
lemma map_upds_xchg_snd:
"⟦ length xs ≤ length ys; length xs ≤ length zs; ∀i. i < length xs ⟶ ys ! i = zs ! i ⟧
⟹ f(xs [↦] ys) = f(xs [↦] zs)"
proof(induct xs arbitrary: ys zs f)
case Nil thus ?case by simp
next
case (Cons x xs)
note IH = ‹⋀f ys zs. ⟦ length xs ≤ length ys; length xs ≤ length zs; ∀i<length xs. ys ! i = zs ! i⟧
⟹ f(xs [↦] ys) = f(xs [↦] zs)›
note leny = ‹length (x # xs) ≤ length ys›
note lenz = ‹length (x # xs) ≤ length zs›
note nth = ‹∀i<length (x # xs). ys ! i = zs ! i›
from lenz obtain z zs' where zs [simp]: "zs = z # zs'" by(cases zs, auto)
from leny obtain y ys' where ys [simp]: "ys = y # ys'" by(cases ys, auto)
from lenz leny nth have "(f(x ↦ y))(xs [↦] ys') = (f(x ↦ y))(xs [↦] zs')"
by-(rule IH, auto)
moreover from nth have "y = z" by auto
ultimately show ?case by(simp add: map_upds_def)
qed
subsection ‹‹distinct_fst››
definition
distinct_fst :: "('a × 'b) list ⇒ bool"
where
"distinct_fst ≡ distinct ∘ map fst"
lemma distinct_fst_Nil [simp]:
"distinct_fst []"
apply (unfold distinct_fst_def)
apply (simp (no_asm))
done
lemma distinct_fst_Cons [simp]:
"distinct_fst ((k,x)#kxs) = (distinct_fst kxs ∧ (∀y. (k,y) ∉ set kxs))"
apply (unfold distinct_fst_def)
apply (auto simp:image_def)
done
lemma distinct_fstD: "⟦ distinct_fst xs; (x, y) ∈ set xs; (x, z) ∈ set xs ⟧ ⟹ y = z"
by(induct xs) auto
lemma map_of_SomeI:
"⟦ distinct_fst kxs; (k,x) ∈ set kxs ⟧ ⟹ map_of kxs k = Some x"
by (induct kxs) (auto simp:fun_upd_apply)
lemma rel_option_Some1:
"rel_option R (Some x) y ⟷ (∃y'. y = Some y' ∧ R x y')"
by(cases y) simp_all
lemma rel_option_Some2:
"rel_option R x (Some y) ⟷ (∃x'. x = Some x' ∧ R x' y)"
by(cases x) simp_all
subsection ‹Using @{term list_all2} for relations›
definition
fun_of :: "('a × 'b) set ⇒ 'a ⇒ 'b ⇒ bool"
where
"fun_of S ≡ λx y. (x,y) ∈ S"
text ‹Convenience lemmas›
declare fun_of_def [simp]
lemma rel_list_all2_Cons [iff]:
"list_all2 (fun_of S) (x#xs) (y#ys) =
((x,y) ∈ S ∧ list_all2 (fun_of S) xs ys)"
by simp
lemma rel_list_all2_Cons1:
"list_all2 (fun_of S) (x#xs) ys =
(∃z zs. ys = z#zs ∧ (x,z) ∈ S ∧ list_all2 (fun_of S) xs zs)"
by (cases ys) auto
lemma rel_list_all2_Cons2:
"list_all2 (fun_of S) xs (y#ys) =
(∃z zs. xs = z#zs ∧ (z,y) ∈ S ∧ list_all2 (fun_of S) zs ys)"
by (cases xs) auto
lemma rel_list_all2_refl:
"(⋀x. (x,x) ∈ S) ⟹ list_all2 (fun_of S) xs xs"
by (simp add: list_all2_refl)
lemma rel_list_all2_antisym:
"⟦ (⋀x y. ⟦(x,y) ∈ S; (y,x) ∈ T⟧ ⟹ x = y);
list_all2 (fun_of S) xs ys; list_all2 (fun_of T) ys xs ⟧ ⟹ xs = ys"
by (rule list_all2_antisym) auto
lemma rel_list_all2_trans:
"⟦ ⋀a b c. ⟦(a,b) ∈ R; (b,c) ∈ S⟧ ⟹ (a,c) ∈ T;
list_all2 (fun_of R) as bs; list_all2 (fun_of S) bs cs⟧
⟹ list_all2 (fun_of T) as cs"
by (rule list_all2_trans) auto
lemma rel_list_all2_update_cong:
"⟦ i<size xs; list_all2 (fun_of S) xs ys; (x,y) ∈ S ⟧
⟹ list_all2 (fun_of S) (xs[i:=x]) (ys[i:=y])"
by (simp add: list_all2_update_cong)
lemma rel_list_all2_nthD:
"⟦ list_all2 (fun_of S) xs ys; p < size xs ⟧ ⟹ (xs!p,ys!p) ∈ S"
by (drule list_all2_nthD) auto
lemma rel_list_all2I:
"⟦ length a = length b; ⋀n. n < length a ⟹ (a!n,b!n) ∈ S ⟧ ⟹ list_all2 (fun_of S) a b"
by (erule list_all2_all_nthI) simp
declare fun_of_def [simp del]
lemma list_all2_induct[consumes 1, case_names Nil Cons]:
assumes major: "list_all2 P xs ys"
and Nil: "Q [] []"
and Cons: "⋀x xs y ys. ⟦ P x y; list_all2 P xs ys; Q xs ys ⟧ ⟹ Q (x # xs) (y # ys)"
shows "Q xs ys"
using major
by(induct xs arbitrary: ys)(auto simp add: list_all2_Cons1 Nil intro!: Cons)
lemma list_all2_split:
assumes major: "list_all2 P xs ys"
and split: "⋀x y. P x y ⟹ ∃z. Q x z ∧ R z y"
shows "∃zs. list_all2 Q xs zs ∧ list_all2 R zs ys"
using major
by(induct rule: list_all2_induct)(auto dest: split)
lemma list_all2_refl_conv:
"list_all2 P xs xs ⟷ (∀x∈set xs. P x x)"
unfolding list_all2_conv_all_nth Ball_def in_set_conv_nth
by auto
lemma list_all2_op_eq [simp]:
"list_all2 (=) xs ys ⟷ xs = ys"
by(induct xs arbitrary: ys)(auto simp add: list_all2_Cons1)
lemmas filter_replicate_conv = filter_replicate
lemma length_greater_Suc_0_conv: "Suc 0 < length xs ⟷ (∃x x' xs'. xs = x # x' # xs')"
by(cases xs, auto simp add: neq_Nil_conv)
lemmas zip_same_conv = zip_same_conv_map
lemma nth_Cons_subtract: "0 < n ⟹ (x # xs) ! n = xs ! (n - 1)"
by(auto simp add: nth_Cons split: nat.split)
lemma f_nth_set:
"⟦ f (xs ! n) = v; n < length xs ⟧ ⟹ v ∈ f ` set xs"
unfolding set_conv_nth by auto
lemma nth_concat_eqI:
"⟦ n = sum_list (map length (take i xss)) + k; i < length xss; k < length (xss ! i); x = xss ! i ! k ⟧
⟹ concat xss ! n = x"
apply(induct xss arbitrary: n i k)
apply simp
apply simp
apply(case_tac i)
apply(simp add: nth_append)
apply(simp add: nth_append)
done
lemma replicate_eq_append_conv:
"(replicate n x = xs @ ys) = (∃m≤n. xs = replicate m x ∧ ys = replicate (n-m) x)"
proof(induct n arbitrary: xs ys)
case 0 thus ?case by simp
next
case (Suc n xs ys)
have IH: "⋀xs ys. (replicate n x = xs @ ys) = (∃m≤n. xs = replicate m x ∧ ys = replicate (n - m) x)" by fact
show ?case
proof(unfold replicate_Suc, rule iffI)
assume a: "x # replicate n x = xs @ ys"
show "∃m≤Suc n. xs = replicate m x ∧ ys = replicate (Suc n - m) x"
proof(cases xs)
case Nil
thus ?thesis using a
by(auto)
next
case (Cons X XS)
with a have x: "x = X" and "replicate n x = XS @ ys" by auto
hence "∃m≤n. XS = replicate m x ∧ ys = replicate (n - m) x"
by -(rule IH[THEN iffD1])
then obtain m where "m ≤ n" and XS: "XS = replicate m x" and ys: "ys = replicate (n - m) x" by blast
with x Cons show ?thesis
by(fastforce)
qed
next
assume "∃m≤Suc n. xs = replicate m x ∧ ys = replicate (Suc n - m) x"
then obtain m where m: "m ≤ Suc n" and xs: "xs = replicate m x" and ys: "ys = replicate (Suc n - m) x" by blast
thus "x # replicate n x = xs @ ys"
by(simp add: replicate_add[THEN sym])
qed
qed
lemma replicate_Suc_snoc:
"replicate (Suc n) x = replicate n x @ [x]"
by (metis replicate_Suc replicate_append_same)
lemma map_eq_append_conv:
"map f xs = ys @ zs ⟷ (∃ys' zs'. map f ys' = ys ∧ map f zs' = zs ∧ xs = ys' @ zs')"
apply(rule iffI)
apply(metis append_eq_conv_conj append_take_drop_id drop_map take_map)
by(clarsimp)
lemma append_eq_map_conv:
"ys @ zs = map f xs ⟷ (∃ys' zs'. map f ys' = ys ∧ map f zs' = zs ∧ xs = ys' @ zs')"
unfolding map_eq_append_conv[symmetric]
by auto
lemma map_eq_map_conv:
"map f xs = map g ys ⟷ list_all2 (λx y. f x = g y) xs ys"
apply(induct xs arbitrary: ys)
apply(auto simp add: list_all2_Cons1 Cons_eq_map_conv)
done
lemma map_eq_all_nth_conv:
"map f xs = ys ⟷ length xs = length ys ∧ (∀n < length xs. f (xs ! n) = ys ! n)"
apply(induct xs arbitrary: ys)
apply(fastforce simp add: nth_Cons Suc_length_conv split: nat.splits)+
done
lemma take_eq_take_le_eq:
"⟦ take n xs = take n ys; m ≤ n ⟧ ⟹ take m xs = take m ys"
by(metis min.absorb_iff1 take_take)
lemma take_list_update_beyond:
"n ≤ m ⟹ take n (xs[m := x]) = take n xs"
by(cases "n ≤ length xs")(rule nth_take_lemma, simp_all)
lemma hd_drop_conv_nth:
"n < length xs ⟹ hd (drop n xs) = xs ! n"
by(rule hd_drop_conv_nth) (metis list.size(3) not_less0)
lemma set_tl_subset: "set (tl xs) ⊆ set xs"
by(cases xs) auto
lemma tl_conv_drop: "tl xs = drop 1 xs"
by(cases xs) simp_all
lemma takeWhile_eq_Nil_dropWhile_eq_Nil_imp_Nil:
"⟦ takeWhile P xs = []; dropWhile P xs = [] ⟧ ⟹ xs = []"
by (metis dropWhile_eq_drop drop_0 list.size(3))
lemma takeWhile_eq_Nil_conv:
"takeWhile P xs = [] ⟷ (xs = [] ∨ ¬ P (hd xs))"
by(cases xs) simp_all
lemma dropWhile_append1': "dropWhile P xs ≠ [] ⟹ dropWhile P (xs @ ys) = dropWhile P xs @ ys"
by(cases xs) auto
lemma dropWhile_append2': "dropWhile P xs = [] ⟹ dropWhile P (xs @ ys) = dropWhile P ys"
by(simp)
lemma takeWhile_append1': "dropWhile P xs ≠ [] ⟹ takeWhile P (xs @ ys) = takeWhile P xs"
by auto
lemma takeWhile_takeWhile: "takeWhile P (takeWhile Q xs) = takeWhile (λx. P x ∧ Q x) xs"
by(induct xs) simp_all
lemma dropWhile_eq_ConsD:
"dropWhile P xs = y # ys ⟹ y ∈ set xs ∧ ¬ P y"
by(induct xs)(auto split: if_split_asm)
lemma dropWhile_eq_hd_conv: "dropWhile P xs = hd xs # rest ⟷ xs ≠ [] ∧ rest = tl xs ∧ ¬ P (hd xs)"
by (metis append_Nil append_is_Nil_conv dropWhile_eq_Cons_conv list.sel(1) neq_Nil_conv takeWhile_dropWhile_id takeWhile_eq_Nil_conv list.sel(3))
lemma dropWhile_eq_same_conv: "dropWhile P xs = xs ⟷ (xs = [] ∨ ¬ P (hd xs))"
by (metis dropWhile.simps(1) eq_Nil_appendI hd_dropWhile takeWhile_dropWhile_id takeWhile_eq_Nil_conv)
lemma subset_code [code_unfold]:
"set xs ⊆ set ys ⟷ (∀x ∈ set xs. x ∈ set ys)"
by(rule Set.subset_eq)
lemma eval_bot [simp]:
"Predicate.eval bot = (λ_. False)"
by(auto simp add: fun_eq_iff)
lemma not_is_emptyE:
assumes "¬ Predicate.is_empty P"
obtains x where "Predicate.eval P x"
using assms
by(fastforce simp add: Predicate.is_empty_def bot_pred_def intro!: pred_iffI)
lemma is_emptyD:
assumes "Predicate.is_empty P"
shows "Predicate.eval P x ⟹ False"
using assms
by(simp add: Predicate.is_empty_def bot_pred_def bot_apply Set.empty_def)
lemma eval_bind_conv:
"Predicate.eval (P ⤜ R) y = (∃x. Predicate.eval P x ∧ Predicate.eval (R x) y)"
by(blast elim: bindE intro: bindI)
lemma eval_single_conv: "Predicate.eval (Predicate.single a) b ⟷ a = b"
by(blast intro: singleI elim: singleE)
lemma conj_asm_conv_imp:
"(A ∧ B ⟹ PROP C) ≡ (A ⟹ B ⟹ PROP C)"
apply(rule equal_intr_rule)
apply(erule meta_mp)
apply(erule (1) conjI)
apply(erule meta_impE)
apply(erule conjunct1)
apply(erule meta_mp)
apply(erule conjunct2)
done
lemma meta_all_eq_conv: "(⋀a. a = b ⟹ PROP P a) ≡ PROP P b"
apply(rule equal_intr_rule)
apply(erule meta_allE)
apply(erule meta_mp)
apply(rule refl)
apply(hypsubst)
apply assumption
done
lemma meta_all_eq_conv2: "(⋀a. b = a ⟹ PROP P a) ≡ PROP P b"
apply(rule equal_intr_rule)
apply(erule meta_allE)
apply(erule meta_mp)
apply(rule refl)
apply(hypsubst)
apply assumption
done
lemma disj_split:
"P (a ∨ b) ⟷ (a ⟶ P True) ∧ (b ⟶ P True) ∧ (¬ a ∧ ¬ b ⟶ P False)"
apply(cases a)
apply(case_tac [!] b)
apply auto
done
lemma disj_split_asm:
"P (a ∨ b) ⟷ ¬ (a ∧ ¬ P True ∨ b ∧ ¬ P True ∨ ¬ a ∧ ¬ b ∧ ¬ P False)"
apply(auto simp add: disj_split[of P])
done
lemma disjCE:
assumes "P ∨ Q"
obtains P | "Q" "¬ P"
using assms by blast
lemma case_option_conv_if:
"(case v of None ⇒ f | Some x ⇒ g x) = (if ∃a. v = Some a then g (the v) else f)"
by(simp)
lemma LetI: "(⋀x. x = t ⟹ P x) ⟹ let x = t in P x"
by(simp)
simproc_setup rearrange_eqs ("Pure.all t") = ‹
let
fun swap_params_conv ctxt i j cv =
let
fun conv1 0 ctxt = Conv.forall_conv (cv o snd) ctxt
| conv1 k ctxt =
Conv.rewr_conv @{thm swap_params} then_conv
Conv.forall_conv (conv1 (k - 1) o snd) ctxt
fun conv2 0 ctxt = conv1 j ctxt
| conv2 k ctxt = Conv.forall_conv (conv2 (k - 1) o snd) ctxt
in conv2 i ctxt end;
fun swap_prems_conv 0 = Conv.all_conv
| swap_prems_conv i =
Conv.implies_concl_conv (swap_prems_conv (i - 1)) then_conv
Conv.rewr_conv Drule.swap_prems_eq;
fun find_eq ctxt t =
let
val l = length (Logic.strip_params t);
val Hs = Logic.strip_assums_hyp t;
fun find (i, (_ $ (Const ("HOL.eq", _) $ Bound j $ _))) = SOME (i, j)
| find (i, (_ $ (Const ("HOL.eq", _) $ _ $ Bound j))) = SOME (i, j)
| find _ = NONE
in
(case get_first find (map_index I Hs) of
NONE => NONE
| SOME (0, 0) => NONE
| SOME (i, j) => SOME (i, l - j - 1, j))
end;
fun mk_swap_rrule ctxt ct =
(case find_eq ctxt (Thm.term_of ct) of
NONE => NONE
| SOME (i, k, j) => SOME (swap_params_conv ctxt k j (K (swap_prems_conv i)) ct))
in
fn _ => mk_swap_rrule
end
›
declare [[simproc del: rearrange_eqs]]
lemmas meta_onepoint = meta_all_eq_conv meta_all_eq_conv2
lemma meta_all2_eq_conv: "(⋀a b. a = c ⟹ PROP P a b) ≡ (⋀b. PROP P c b)"
apply(rule equal_intr_rule)
apply(erule meta_allE)+
apply(erule meta_mp)
apply(rule refl)
apply(erule meta_allE)
apply simp
done
lemma meta_all3_eq_conv: "(⋀a b c. a = d ⟹ PROP P a b c) ≡ (⋀b c. PROP P d b c)"
apply(rule equal_intr_rule)
apply(erule meta_allE)+
apply(erule meta_mp)
apply(rule refl)
apply(erule meta_allE)+
apply simp
done
lemma meta_all4_eq_conv: "(⋀a b c d. a = e ⟹ PROP P a b c d) ≡ (⋀b c d. PROP P e b c d)"
apply(rule equal_intr_rule)
apply(erule meta_allE)+
apply(erule meta_mp)
apply(rule refl)
apply(erule meta_allE)+
apply simp
done
lemma meta_all5_eq_conv: "(⋀a b c d e. a = f ⟹ PROP P a b c d e) ≡ (⋀b c d e. PROP P f b c d e)"
apply(rule equal_intr_rule)
apply(erule meta_allE)+
apply(erule meta_mp)
apply(rule refl)
apply(erule meta_allE)+
apply simp
done
lemma inj_on_image_mem_iff:
"⟦ inj_on f A; B ⊆ A; a ∈ A ⟧ ⟹ f a ∈ f ` B ⟷ a ∈ B"
by(metis inv_into_f_eq inv_into_image_cancel rev_image_eqI)
lemma sum_hom:
assumes hom_add [simp]: "⋀a b. f (a + b) = f a + f b"
and hom_0 [simp]: "f 0 = 0"
shows "sum (f ∘ h) A = f (sum h A)"
proof(cases "finite A")
case False thus ?thesis by simp
next
case True thus ?thesis
by(induct) simp_all
qed
lemma sum_upto_add_nat:
"a ≤ b ⟹ sum f {..<(a :: nat)} + sum f {a..<b} = sum f {..<b}"
by (metis atLeast0LessThan le0 sum.atLeastLessThan_concat)
lemma nat_fun_sum_eq_conv:
fixes f :: "'a ⇒ nat"
shows "(λa. f a + g a) = (λa. 0) ⟷ f = (λa .0) ∧ g = (λa. 0)"
by(auto simp add: fun_eq_iff)
lemma in_ran_conv: "v ∈ ran m ⟷ (∃k. m k = Some v)"
by(simp add: ran_def)
lemma map_le_dom_eq_conv_eq:
"⟦ m ⊆⇩m m'; dom m = dom m' ⟧ ⟹ m = m'"
by (metis map_le_antisym map_le_def)
lemma map_leI:
"(⋀k v. f k = Some v ⟹ g k = Some v) ⟹ f ⊆⇩m g"
unfolding map_le_def by auto
lemma map_le_SomeD: "⟦ m ⊆⇩m m'; m x = ⌊y⌋ ⟧ ⟹ m' x = ⌊y⌋"
by(auto simp add: map_le_def dest: bspec)
lemma map_le_same_upd:
"f x = None ⟹ f ⊆⇩m f(x ↦ y)"
by(auto simp add: map_le_def)
lemma map_upd_map_add: "X(V ↦ v) = (X ++ [V ↦ v])"
by(simp)
lemma foldr_filter_conv:
"foldr f (filter P xs) = foldr (λx s. if P x then f x s else s) xs"
by(induct xs)(auto intro: ext)
lemma foldr_insert_conv_set:
"foldr insert xs A = A ∪ set xs"
by(induct xs arbitrary: A) auto
lemma snd_o_Pair_conv_id: "snd o Pair a = id"
by(simp add: o_def id_def)
lemma if_intro:
"⟦ P ⟹ A; ¬ P ⟹ B ⟧ ⟹ if P then A else B"
by(auto)
lemma ex_set_conv: "(∃x. x ∈ set xs) ⟷ xs ≠ []"
apply(auto)
apply(auto simp add: neq_Nil_conv)
done
lemma subset_Un1: "A ⊆ B ⟹ A ⊆ B ∪ C" by blast
lemma subset_Un2: "A ⊆ C ⟹ A ⊆ B ∪ C" by blast
lemma subset_insert: "A ⊆ B ⟹ A ⊆ insert a B" by blast
lemma UNION_subsetD: "⟦ (⋃x∈A. f x) ⊆ B; a ∈ A ⟧ ⟹ f a ⊆ B" by blast
lemma Collect_eq_singleton_conv:
"{a. P a} = {a} ⟷ P a ∧ (∀a'. P a' ⟶ a = a')"
by(auto)
lemma Collect_conv_UN_singleton: "{f x|x. x ∈ P} = (⋃x∈P. {f x})"
by blast
lemma if_else_if_else_eq_if_else [simp]:
"(if b then x else if b then y else z) = (if b then x else z)"
by(simp)
lemma rec_prod_split [simp]: "old.rec_prod = case_prod"
by(simp add: fun_eq_iff)
lemma inj_Pair_snd [simp]: "inj (Pair x)"
by(rule injI) auto
lemma rtranclp_False [simp]: "(λa b. False)⇧*⇧* = (=)"
by(auto simp add: fun_eq_iff elim: rtranclp_induct)
lemmas rtranclp_induct3 =
rtranclp_induct[where a="(ax, ay, az)" and b="(bx, by, bz)", split_rule, consumes 1, case_names refl step]
lemmas tranclp_induct3 =
tranclp_induct[where a="(ax, ay, az)" and b="(bx, by, bz)", split_rule, consumes 1, case_names refl step]
lemmas rtranclp_induct4 =
rtranclp_induct[where a="(ax, ay, az, aw)" and b="(bx, by, bz, bw)", split_rule, consumes 1, case_names refl step]
lemmas tranclp_induct4 =
tranclp_induct[where a="(ax, ay, az, aw)" and b="(bx, by, bz, bw)", split_rule, consumes 1, case_names refl step]
lemmas converse_tranclp_induct2 =
converse_tranclp_induct [of _ "(ax,ay)" "(bx,by)", split_rule,
consumes 1, case_names base step]
lemma wfP_induct' [consumes 1, case_names wfP]:
"⟦wfP r; ⋀x. (⋀y. r y x ⟹ P y) ⟹ P x⟧ ⟹ P a"
by(blast intro: wfP_induct)
lemma wfP_induct2 [consumes 1, case_names wfP]:
"⟦wfP r; ⋀x x'. (⋀y y'. r (y, y') (x, x') ⟹ P y y') ⟹ P x x' ⟧ ⟹ P x x'"
by(drule wfP_induct'[where P="λ(x, y). P x y"]) blast+
lemma wfP_minimalE:
assumes "wfP r"
and "P x"
obtains z where "P z" "r^** z x" "⋀y. r y z ⟹ ¬ P y"
proof -
let ?Q = "λx'. P x' ∧ r^** x' x"
from ‹P x› have "?Q x" by blast
from ‹wfP r› have "⋀Q. x ∈ Q ⟶ (∃z∈Q. ∀y. r y z ⟶ y ∉ Q)"
unfolding wfP_eq_minimal by blast
from this[rule_format, of "Collect ?Q"] ‹?Q x›
obtain z where "?Q z" and min: "⋀y. r y z ⟹ ¬ ?Q y" by auto
from ‹?Q z› have "P z" "r^** z x" by auto
moreover
{ fix y
assume "r y z"
hence "¬ ?Q y" by(rule min)
moreover from ‹r y z› ‹r^** z x› have "r^** y x"
by(rule converse_rtranclp_into_rtranclp)
ultimately have "¬ P y" by blast }
ultimately show thesis ..
qed
lemma coinduct_set_wf [consumes 3, case_names coinduct, case_conclusion coinduct wait step]:
assumes "mono f" "wf r" "(a, b) ∈ X"
and step: "⋀x b. (x, b) ∈ X ⟹ (∃b'. (b', b) ∈ r ∧ (x, b') ∈ X) ∨ (x ∈ f (fst ` X ∪ gfp f))"
shows "a ∈ gfp f"
proof -
from ‹(a, b) ∈ X› have "a ∈ fst ` X" by(auto intro: rev_image_eqI)
moreover
{ fix a b
assume "(a, b) ∈ X"
with ‹wf r› have "a ∈ f (fst ` X ∪ gfp f)"
by(induct)(blast dest: step) }
hence "fst ` X ⊆ f (fst ` X ∪ gfp f)" by(auto)
ultimately show ?thesis by(rule coinduct_set[OF ‹mono f›])
qed
subsection ‹reflexive transitive closure for label relations›
inductive converse3p :: "('a ⇒ 'b ⇒ 'c ⇒ bool) ⇒ 'c ⇒ 'b ⇒ 'a ⇒ bool"
for r :: "'a ⇒ 'b ⇒ 'c ⇒ bool"
where
converse3pI: "r a b c ⟹ converse3p r c b a"
lemma converse3p_converse3p: "converse3p (converse3p r) = r"
by(auto intro: converse3pI intro!: ext elim: converse3p.cases)
lemma converse3pD: "converse3p r c b a ⟹ r a b c"
by(auto elim: converse3p.cases)
inductive rtrancl3p :: "('a ⇒ 'b ⇒ 'a ⇒ bool) ⇒ 'a ⇒ 'b list ⇒ 'a ⇒ bool"
for r :: "'a ⇒ 'b ⇒ 'a ⇒ bool"
where
rtrancl3p_refl [intro!, simp]: "rtrancl3p r a [] a"
| rtrancl3p_step: "⟦ rtrancl3p r a bs a'; r a' b a'' ⟧ ⟹ rtrancl3p r a (bs @ [b]) a''"
lemmas rtrancl3p_induct3 =
rtrancl3p.induct[of _ "(ax,ay,az)" _ "(cx,cy,cz)", split_format (complete),
consumes 1, case_names refl step]
lemmas rtrancl3p_induct4 =
rtrancl3p.induct[of _ "(ax,ay,az,aw)" _ "(cx,cy,cz,cw)", split_format (complete),
consumes 1, case_names refl step]
lemma rtrancl3p_induct4' [consumes 1, case_names refl step]:
assumes major: "rtrancl3p r (ax, (ay, az), aw) bs (cx, (cy, cz), cw)"
and refl: "⋀a aa b ba. P a aa b ba [] a aa b ba"
and step: "⋀a aa b ba bs ab ac bb bc bd ad ae be bf.
⟦ rtrancl3p r (a, (aa, b), ba) bs (ab, (ac, bb), bc);
P a aa b ba bs ab ac bb bc; r (ab, (ac, bb), bc) bd (ad, (ae, be), bf) ⟧
⟹ P a aa b ba (bs @ [bd]) ad ae be bf"
shows "P ax ay az aw bs cx cy cz cw"
using major
apply -
apply(drule_tac P="λ(a, (aa, b), ba) bs (cx, (cy, cz), cw). P a aa b ba bs cx cy cz cw" in rtrancl3p.induct)
by(auto intro: refl step)
lemma rtrancl3p_induct1:
"⟦ rtrancl3p r a bs c; P a; ⋀bs c b d. ⟦ rtrancl3p r a bs c; r c b d; P c ⟧ ⟹ P d ⟧ ⟹ P c"
apply(induct rule: rtrancl3p.induct)
apply(auto)
done
inductive_cases rtrancl3p_cases:
"rtrancl3p r x [] y"
"rtrancl3p r x (b # bs) y"
lemma rtrancl3p_trans [trans]:
assumes one: "rtrancl3p r a bs a'"
and two: "rtrancl3p r a' bs' a''"
shows "rtrancl3p r a (bs @ bs') a''"
using two one
proof(induct rule: rtrancl3p.induct)
case rtrancl3p_refl thus ?case by simp
next
case rtrancl3p_step thus ?case
by(auto simp only: append_assoc[symmetric] intro: rtrancl3p.rtrancl3p_step)
qed
lemma rtrancl3p_step_converse:
assumes step: "r a b a'"
and stepify: "rtrancl3p r a' bs a''"
shows "rtrancl3p r a (b # bs) a''"
using stepify step
proof(induct rule: rtrancl3p.induct)
case rtrancl3p_refl
with rtrancl3p.rtrancl3p_refl[where r=r and a=a] show ?case
by(auto dest: rtrancl3p.rtrancl3p_step simp del: rtrancl3p.rtrancl3p_refl)
next
case rtrancl3p_step thus ?case
unfolding append_Cons[symmetric]
by -(rule rtrancl3p.rtrancl3p_step)
qed
lemma converse_rtrancl3p_step:
"rtrancl3p r a (b # bs) a'' ⟹ ∃a'. r a b a' ∧ rtrancl3p r a' bs a''"
apply(induct bs arbitrary: a'' rule: rev_induct)
apply(erule rtrancl3p.cases)
apply(clarsimp)+
apply(erule rtrancl3p.cases)
apply(clarsimp)
apply(rule_tac x="a''a" in exI)
apply(clarsimp)
apply(clarsimp)
apply(erule rtrancl3p.cases)
apply(clarsimp)
apply(clarsimp)
by(fastforce intro: rtrancl3p_step)
lemma converse_rtrancl3pD:
"rtrancl3p (converse3p r) a' bs a ⟹ rtrancl3p r a (rev bs) a'"
apply(induct rule: rtrancl3p.induct)
apply(fastforce intro: rtrancl3p.intros)
apply(auto dest: converse3pD intro: rtrancl3p_step_converse)
done
lemma rtrancl3p_converseD:
"rtrancl3p r a bs a' ⟹ rtrancl3p (converse3p r) a' (rev bs) a"
proof(induct rule: rtrancl3p.induct)
case rtrancl3p_refl thus ?case
by(auto intro: rtrancl3p.intros)
next
case rtrancl3p_step thus ?case
by(auto intro: rtrancl3p_step_converse converse3p.intros)
qed
lemma rtrancl3p_converse_induct [consumes 1, case_names refl step]:
assumes ih: "rtrancl3p r a bs a''"
and refl: "⋀a. P a [] a"
and step: "⋀a b a' bs a''. ⟦ rtrancl3p r a' bs a''; r a b a'; P a' bs a'' ⟧ ⟹ P a (b # bs) a''"
shows "P a bs a''"
using ih
proof(induct bs arbitrary: a a'')
case Nil thus ?case
by(auto elim: rtrancl3p.cases intro: refl)
next
case Cons thus ?case
by(auto dest!: converse_rtrancl3p_step intro: step)
qed
lemma rtrancl3p_converse_induct' [consumes 1, case_names refl step]:
assumes ih: "rtrancl3p r a bs a''"
and refl: "P a'' []"
and step: "⋀a b a' bs. ⟦ rtrancl3p r a' bs a''; r a b a'; P a' bs ⟧ ⟹ P a (b # bs)"
shows "P a bs"
using rtrancl3p_converse_induct[OF ih, where P="λa bs a'. a' = a'' ⟶ P a bs"]
by(auto intro: refl step)
lemma rtrancl3p_converseE[consumes 1, case_names refl step]:
"⟦ rtrancl3p r a bs a'';
⟦ a = a''; bs = [] ⟧ ⟹ thesis;
⋀bs' b a'. ⟦ bs = b # bs'; r a b a'; rtrancl3p r a' bs' a'' ⟧ ⟹ thesis ⟧
⟹ thesis"
by(induct rule: rtrancl3p_converse_induct)(auto)
lemma rtrancl3p_induct' [consumes 1, case_names refl step]:
assumes major: "rtrancl3p r a bs c"
and refl: "P a [] a"
and step: "⋀bs a' b a''. ⟦ rtrancl3p r a bs a'; P a bs a'; r a' b a'' ⟧
⟹ P a (bs @ [b]) a''"
shows "P a bs c"
proof -
from major have "(P a [] a ∧ (∀bs a' b a''. rtrancl3p r a bs a' ∧ P a bs a' ∧ r a' b a'' ⟶ P a (bs @ [b]) a'')) ⟶ P a bs c"
by-(erule rtrancl3p.induct, blast+)
with refl step show ?thesis by blast
qed
lemma r_into_rtrancl3p:
"r a b a' ⟹ rtrancl3p r a [b] a'"
by(rule rtrancl3p_step_converse) auto
lemma rtrancl3p_appendE:
assumes "rtrancl3p r a (bs @ bs') a''"
obtains a' where "rtrancl3p r a bs a'" "rtrancl3p r a' bs' a''"
using assms
apply(induct a "bs @ bs'" arbitrary: bs rule: rtrancl3p_converse_induct')
apply(fastforce intro: rtrancl3p_step_converse simp add: Cons_eq_append_conv)+
done
lemma rtrancl3p_Cons:
"rtrancl3p r a (b # bs) a' ⟷ (∃a''. r a b a'' ∧ rtrancl3p r a'' bs a')"
by(auto intro: rtrancl3p_step_converse converse_rtrancl3p_step)
lemma rtrancl3p_Nil:
"rtrancl3p r a [] a' ⟷ a = a'"
by(auto elim: rtrancl3p_cases)
definition invariant3p :: "('a ⇒ 'b ⇒ 'a ⇒ bool) ⇒ 'a set ⇒ bool"
where "invariant3p r I ⟷ (∀s tl s'. s ∈ I ⟶ r s tl s' ⟶ s' ∈ I)"
lemma invariant3pI: "(⋀s tl s'. ⟦ s ∈ I; r s tl s' ⟧ ⟹ s' ∈ I) ⟹ invariant3p r I"
unfolding invariant3p_def by blast
lemma invariant3pD: "⋀tl. ⟦ invariant3p r I; r s tl s'; s ∈ I ⟧ ⟹ s' ∈ I"
unfolding invariant3p_def by(blast)
lemma invariant3p_rtrancl3p:
assumes inv: "invariant3p r I"
and rtrancl: "rtrancl3p r a bs a'"
and start: "a ∈ I"
shows "a' ∈ I"
using rtrancl start by(induct)(auto dest: invariant3pD[OF inv])
lemma invariant3p_UNIV [simp, intro!]:
"invariant3p r UNIV"
by(blast intro: invariant3pI)
lemma invarinat3p_empty [simp, intro!]:
"invariant3p r {}"
by(blast intro: invariant3pI)
lemma invariant3p_IntI [simp, intro]:
"⟦ invariant3p r I; invariant3p r J ⟧ ⟹ invariant3p r (I ∩ J)"
by(blast dest: invariant3pD intro: invariant3pI)
subsection ‹Concatenation for @{typ String.literal}›
definition concat :: "String.literal list ⇒ String.literal"
where [code_abbrev, code del]: "concat = sum_list"
lemma explode_add [simp]:
"String.explode (s + t) = String.explode s @ String.explode t"
by (fact plus_literal.rep_eq)
code_printing
constant concat ⇀
(SML) "String.concat"
and (Haskell) "concat"
and (OCaml) "String.concat \"\""
hide_const (open) concat
end
Theory FWState
chapter ‹The generic multithreaded semantics›
section ‹State of the multithreaded semantics›
theory FWState
imports
"../Basic/Auxiliary"
begin
datatype lock_action =
Lock
| Unlock
| UnlockFail
| ReleaseAcquire
datatype ('t,'x,'m) new_thread_action =
NewThread 't 'x 'm
| ThreadExists 't bool
datatype 't conditional_action =
Join 't
| Yield
datatype ('t, 'w) wait_set_action =
Suspend 'w
| Notify 'w
| NotifyAll 'w
| WakeUp 't
| Notified
| WokenUp
datatype 't interrupt_action
= IsInterrupted 't bool
| Interrupt 't
| ClearInterrupt 't
type_synonym 'l lock_actions = "'l ⇒f lock_action list"
translations
(type) "'l lock_actions" <= (type) "'l ⇒f lock_action list"
type_synonym
('l,'t,'x,'m,'w,'o) thread_action =
"'l lock_actions × ('t,'x,'m) new_thread_action list ×
't conditional_action list × ('t, 'w) wait_set_action list ×
't interrupt_action list × 'o list"
print_translation ‹
let
fun tr'
[Const (@{type_syntax finfun}, _) $ l $
(Const (@{type_syntax list}, _) $ Const (@{type_syntax lock_action}, _)),
Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax list}, _) $ (Const (@{type_syntax new_thread_action}, _) $ t1 $ x $ m)) $
(Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax list}, _) $ (Const (@{type_syntax conditional_action}, _) $ t2)) $
(Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax list}, _) $ (Const (@{type_syntax wait_set_action}, _) $ t3 $ w)) $
(Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "interrupt_action"}, _) $ t4)) $
(Const (@{type_syntax "list"}, _) $ o1))))] =
if t1 = t2 andalso t2 = t3 andalso t3 = t4 then Syntax.const @{type_syntax thread_action} $ l $ t1 $ x $ m $ w $ o1
else raise Match;
in [(@{type_syntax "prod"}, K tr')]
end
›
typ "('l,'t,'x,'m,'w,'o) thread_action"
definition locks_a :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ 'l lock_actions" ("⦃_⦄⇘l⇙" [0] 1000) where
"locks_a ≡ fst"
definition thr_a :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ ('t,'x,'m) new_thread_action list" ("⦃_⦄⇘t⇙" [0] 1000) where
"thr_a ≡ fst o snd"
definition cond_a :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ 't conditional_action list" ("⦃_⦄⇘c⇙" [0] 1000) where
"cond_a = fst o snd o snd"
definition wset_a :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ ('t, 'w) wait_set_action list" ("⦃_⦄⇘w⇙" [0] 1000) where
"wset_a = fst o snd o snd o snd"
definition interrupt_a :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ 't interrupt_action list" ("⦃_⦄⇘i⇙" [0] 1000) where
"interrupt_a = fst o snd o snd o snd o snd"
definition obs_a :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ 'o list" ("⦃_⦄⇘o⇙" [0] 1000) where
"obs_a ≡ snd o snd o snd o snd o snd"
lemma locks_a_conv [simp]: "locks_a (ls, ntsjswss) = ls"
by(simp add:locks_a_def)
lemma thr_a_conv [simp]: "thr_a (ls, nts, jswss) = nts"
by(simp add: thr_a_def)
lemma cond_a_conv [simp]: "cond_a (ls, nts, js, wws) = js"
by(simp add: cond_a_def)
lemma wset_a_conv [simp]: "wset_a (ls, nts, js, wss, isobs) = wss"
by(simp add: wset_a_def)
lemma interrupt_a_conv [simp]: "interrupt_a (ls, nts, js, ws, is, obs) = is"
by(simp add: interrupt_a_def)
lemma obs_a_conv [simp]: "obs_a (ls, nts, js, wss, is, obs) = obs"
by(simp add: obs_a_def)
fun ta_update_locks :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ lock_action ⇒ 'l ⇒ ('l,'t,'x,'m,'w,'o) thread_action" where
"ta_update_locks (ls, nts, js, wss, obs) lta l = (ls(l $:= ls $ l @ [lta]), nts, js, wss, obs)"
fun ta_update_NewThread :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ ('t,'x,'m) new_thread_action ⇒ ('l,'t,'x,'m,'w,'o) thread_action" where
"ta_update_NewThread (ls, nts, js, wss, is, obs) nt = (ls, nts @ [nt], js, wss, is, obs)"
fun ta_update_Conditional :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ 't conditional_action ⇒ ('l,'t,'x,'m,'w,'o) thread_action"
where
"ta_update_Conditional (ls, nts, js, wss, is, obs) j = (ls, nts, js @ [j], wss, is, obs)"
fun ta_update_wait_set :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ ('t, 'w) wait_set_action ⇒ ('l,'t,'x,'m,'w,'o) thread_action" where
"ta_update_wait_set (ls, nts, js, wss, is, obs) ws = (ls, nts, js, wss @ [ws], is, obs)"
fun ta_update_interrupt :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ 't interrupt_action ⇒ ('l,'t,'x,'m,'w,'o) thread_action"
where
"ta_update_interrupt (ls, nts, js, wss, is, obs) i = (ls, nts, js, wss, is @ [i], obs)"
fun ta_update_obs :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ 'o ⇒ ('l,'t,'x,'m,'w,'o) thread_action"
where
"ta_update_obs (ls, nts, js, wss, is, obs) ob = (ls, nts, js, wss, is, obs @ [ob])"
abbreviation empty_ta :: "('l,'t,'x,'m,'w,'o) thread_action" where
"empty_ta ≡ (K$ [], [], [], [], [], [])"
notation (input) empty_ta ("ε")
text ‹
Pretty syntax for specifying thread actions:
Write ‹⦃ Lock→l, Unlock→l, Suspend w, Interrupt t⦄› instead of
@{term "((K$ [])(l $:= [Lock, Unlock]), [], [Suspend w], [Interrupt t], [])"}.
‹thread_action'› is a type that contains of all basic thread actions.
Automatically coerce basic thread actions into that type and then dispatch to the right
update function by pattern matching.
For coercion, adhoc overloading replaces the generic injection ‹inject_thread_action›
by the specific ones, i.e. constructors.
To avoid ambiguities with observable actions, the observable actions must be of sort ‹obs_action›,
which the basic thread action types are not.
›
class obs_action
datatype ('l,'t,'x,'m,'w,'o) thread_action'
= LockAction "lock_action × 'l"
| NewThreadAction "('t,'x,'m) new_thread_action"
| ConditionalAction "'t conditional_action"
| WaitSetAction "('t, 'w) wait_set_action"
| InterruptAction "'t interrupt_action"
| ObsAction 'o
setup ‹
Sign.add_const_constraint (@{const_name ObsAction}, SOME @{typ "'o :: obs_action ⇒ ('l,'t,'x,'m,'w,'o) thread_action'"})
›
fun thread_action'_to_thread_action ::
"('l,'t,'x,'m,'w,'o :: obs_action) thread_action' ⇒ ('l,'t,'x,'m,'w,'o) thread_action ⇒ ('l,'t,'x,'m,'w,'o) thread_action"
where
"thread_action'_to_thread_action (LockAction (la, l)) ta = ta_update_locks ta la l"
| "thread_action'_to_thread_action (NewThreadAction nt) ta = ta_update_NewThread ta nt"
| "thread_action'_to_thread_action (ConditionalAction ca) ta = ta_update_Conditional ta ca"
| "thread_action'_to_thread_action (WaitSetAction wa) ta = ta_update_wait_set ta wa"
| "thread_action'_to_thread_action (InterruptAction ia) ta = ta_update_interrupt ta ia"
| "thread_action'_to_thread_action (ObsAction ob) ta = ta_update_obs ta ob"
consts inject_thread_action :: "'a ⇒ ('l,'t,'x,'m,'w,'o) thread_action'"
nonterminal ta_let and ta_lets
syntax
"_ta_snoc" :: "ta_lets ⇒ ta_let ⇒ ta_lets" ("_,/ _")
"_ta_block" :: "ta_lets ⇒ 'a" ("⦃_⦄" [0] 1000)
"_ta_empty" :: "ta_lets" ("")
"_ta_single" :: "ta_let ⇒ ta_lets" ("_")
"_ta_inject" :: "logic ⇒ ta_let" ("(_)")
"_ta_lock" :: "logic ⇒ logic ⇒ ta_let" ("_→_")
translations
"_ta_block _ta_empty" == "CONST empty_ta"
"_ta_block (_ta_single bta)" == "_ta_block (_ta_snoc _ta_empty bta)"
"_ta_inject bta" == "CONST inject_thread_action bta"
"_ta_lock la l" == "CONST inject_thread_action (CONST Pair la l)"
"_ta_block (_ta_snoc btas bta)" == "CONST thread_action'_to_thread_action bta (_ta_block btas)"
adhoc_overloading
inject_thread_action NewThreadAction ConditionalAction WaitSetAction InterruptAction ObsAction LockAction
lemma ta_upd_proj_simps [simp]:
shows ta_obs_proj_simps:
"⦃ta_update_obs ta obs⦄⇘l⇙ = ⦃ta⦄⇘l⇙" "⦃ta_update_obs ta obs⦄⇘t⇙ = ⦃ta⦄⇘t⇙" "⦃ta_update_obs ta obs⦄⇘w⇙ = ⦃ta⦄⇘w⇙"
"⦃ta_update_obs ta obs⦄⇘c⇙ = ⦃ta⦄⇘c⇙" "⦃ta_update_obs ta obs⦄⇘i⇙ = ⦃ta⦄⇘i⇙" "⦃ta_update_obs ta obs⦄⇘o⇙ = ⦃ta⦄⇘o⇙ @ [obs]"
and ta_lock_proj_simps:
"⦃ta_update_locks ta x l⦄⇘l⇙ = (let ls = ⦃ta⦄⇘l⇙ in ls(l $:= ls $ l @ [x]))"
"⦃ta_update_locks ta x l⦄⇘t⇙ = ⦃ta⦄⇘t⇙" "⦃ta_update_locks ta x l⦄⇘w⇙ = ⦃ta⦄⇘w⇙" "⦃ta_update_locks ta x l⦄⇘c⇙ = ⦃ta⦄⇘c⇙"
"⦃ta_update_locks ta x l⦄⇘i⇙ = ⦃ta⦄⇘i⇙" "⦃ta_update_locks ta x l⦄⇘o⇙ = ⦃ta⦄⇘o⇙"
and ta_thread_proj_simps:
"⦃ta_update_NewThread ta t⦄⇘l⇙ = ⦃ta⦄⇘l⇙" "⦃ta_update_NewThread ta t⦄⇘t⇙ = ⦃ta⦄⇘t⇙ @ [t]" "⦃ta_update_NewThread ta t⦄⇘w⇙ = ⦃ta⦄⇘w⇙"
"⦃ta_update_NewThread ta t⦄⇘c⇙ = ⦃ta⦄⇘c⇙" "⦃ta_update_NewThread ta t⦄⇘i⇙ = ⦃ta⦄⇘i⇙" "⦃ta_update_NewThread ta t⦄⇘o⇙ = ⦃ta⦄⇘o⇙"
and ta_wset_proj_simps:
"⦃ta_update_wait_set ta w⦄⇘l⇙ = ⦃ta⦄⇘l⇙" "⦃ta_update_wait_set ta w⦄⇘t⇙ = ⦃ta⦄⇘t⇙" "⦃ta_update_wait_set ta w⦄⇘w⇙ = ⦃ta⦄⇘w⇙ @ [w]"
"⦃ta_update_wait_set ta w⦄⇘c⇙ = ⦃ta⦄⇘c⇙" "⦃ta_update_wait_set ta w⦄⇘i⇙ = ⦃ta⦄⇘i⇙" "⦃ta_update_wait_set ta w⦄⇘o⇙ = ⦃ta⦄⇘o⇙"
and ta_cond_proj_simps:
"⦃ta_update_Conditional ta c⦄⇘l⇙ = ⦃ta⦄⇘l⇙" "⦃ta_update_Conditional ta c⦄⇘t⇙ = ⦃ta⦄⇘t⇙" "⦃ta_update_Conditional ta c⦄⇘w⇙ = ⦃ta⦄⇘w⇙"
"⦃ta_update_Conditional ta c⦄⇘c⇙ = ⦃ta⦄⇘c⇙ @ [c]" "⦃ta_update_Conditional ta c⦄⇘i⇙ = ⦃ta⦄⇘i⇙" "⦃ta_update_Conditional ta c⦄⇘o⇙ = ⦃ta⦄⇘o⇙"
and ta_interrupt_proj_simps:
"⦃ta_update_interrupt ta i⦄⇘l⇙ = ⦃ta⦄⇘l⇙" "⦃ta_update_interrupt ta i⦄⇘t⇙ = ⦃ta⦄⇘t⇙" "⦃ta_update_interrupt ta i⦄⇘c⇙ = ⦃ta⦄⇘c⇙"
"⦃ta_update_interrupt ta i⦄⇘w⇙ = ⦃ta⦄⇘w⇙" "⦃ta_update_interrupt ta i⦄⇘i⇙ = ⦃ta⦄⇘i⇙ @ [i]" "⦃ta_update_interrupt ta i⦄⇘o⇙ = ⦃ta⦄⇘o⇙"
by(cases ta, simp)+
lemma thread_action'_to_thread_action_proj_simps [simp]:
shows thread_action'_to_thread_action_proj_locks_simps:
"⦃thread_action'_to_thread_action (LockAction (la, l)) ta⦄⇘l⇙ = ⦃ta_update_locks ta la l⦄⇘l⇙"
"⦃thread_action'_to_thread_action (NewThreadAction nt) ta⦄⇘l⇙ = ⦃ta_update_NewThread ta nt⦄⇘l⇙"
"⦃thread_action'_to_thread_action (ConditionalAction ca) ta⦄⇘l⇙ = ⦃ta_update_Conditional ta ca⦄⇘l⇙"
"⦃thread_action'_to_thread_action (WaitSetAction wa) ta⦄⇘l⇙ = ⦃ta_update_wait_set ta wa⦄⇘l⇙"
"⦃thread_action'_to_thread_action (InterruptAction ia) ta⦄⇘l⇙ = ⦃ta_update_interrupt ta ia⦄⇘l⇙"
"⦃thread_action'_to_thread_action (ObsAction ob) ta⦄⇘l⇙ = ⦃ta_update_obs ta ob⦄⇘l⇙"
and thread_action'_to_thread_action_proj_nt_simps:
"⦃thread_action'_to_thread_action (LockAction (la, l)) ta⦄⇘t⇙ = ⦃ta_update_locks ta la l⦄⇘t⇙"
"⦃thread_action'_to_thread_action (NewThreadAction nt) ta⦄⇘t⇙ = ⦃ta_update_NewThread ta nt⦄⇘t⇙"
"⦃thread_action'_to_thread_action (ConditionalAction ca) ta⦄⇘t⇙ = ⦃ta_update_Conditional ta ca⦄⇘t⇙"
"⦃thread_action'_to_thread_action (WaitSetAction wa) ta⦄⇘t⇙ = ⦃ta_update_wait_set ta wa⦄⇘t⇙"
"⦃thread_action'_to_thread_action (InterruptAction ia) ta⦄⇘t⇙ = ⦃ta_update_interrupt ta ia⦄⇘t⇙"
"⦃thread_action'_to_thread_action (ObsAction ob) ta⦄⇘t⇙ = ⦃ta_update_obs ta ob⦄⇘t⇙"
and thread_action'_to_thread_action_proj_cond_simps:
"⦃thread_action'_to_thread_action (LockAction (la, l)) ta⦄⇘c⇙ = ⦃ta_update_locks ta la l⦄⇘c⇙"
"⦃thread_action'_to_thread_action (NewThreadAction nt) ta⦄⇘c⇙ = ⦃ta_update_NewThread ta nt⦄⇘c⇙"
"⦃thread_action'_to_thread_action (ConditionalAction ca) ta⦄⇘c⇙ = ⦃ta_update_Conditional ta ca⦄⇘c⇙"
"⦃thread_action'_to_thread_action (WaitSetAction wa) ta⦄⇘c⇙ = ⦃ta_update_wait_set ta wa⦄⇘c⇙"
"⦃thread_action'_to_thread_action (InterruptAction ia) ta⦄⇘c⇙ = ⦃ta_update_interrupt ta ia⦄⇘c⇙"
"⦃thread_action'_to_thread_action (ObsAction ob) ta⦄⇘c⇙ = ⦃ta_update_obs ta ob⦄⇘c⇙"
and thread_action'_to_thread_action_proj_wset_simps:
"⦃thread_action'_to_thread_action (LockAction (la, l)) ta⦄⇘w⇙ = ⦃ta_update_locks ta la l⦄⇘w⇙"
"⦃thread_action'_to_thread_action (NewThreadAction nt) ta⦄⇘w⇙ = ⦃ta_update_NewThread ta nt⦄⇘w⇙"
"⦃thread_action'_to_thread_action (ConditionalAction ca) ta⦄⇘w⇙ = ⦃ta_update_Conditional ta ca⦄⇘w⇙"
"⦃thread_action'_to_thread_action (WaitSetAction wa) ta⦄⇘w⇙ = ⦃ta_update_wait_set ta wa⦄⇘w⇙"
"⦃thread_action'_to_thread_action (InterruptAction ia) ta⦄⇘w⇙ = ⦃ta_update_interrupt ta ia⦄⇘w⇙"
"⦃thread_action'_to_thread_action (ObsAction ob) ta⦄⇘w⇙ = ⦃ta_update_obs ta ob⦄⇘w⇙"
and thread_action'_to_thread_action_proj_interrupt_simps:
"⦃thread_action'_to_thread_action (LockAction (la, l)) ta⦄⇘i⇙ = ⦃ta_update_locks ta la l⦄⇘i⇙"
"⦃thread_action'_to_thread_action (NewThreadAction nt) ta⦄⇘i⇙ = ⦃ta_update_NewThread ta nt⦄⇘i⇙"
"⦃thread_action'_to_thread_action (ConditionalAction ca) ta⦄⇘i⇙ = ⦃ta_update_Conditional ta ca⦄⇘i⇙"
"⦃thread_action'_to_thread_action (WaitSetAction wa) ta⦄⇘i⇙ = ⦃ta_update_wait_set ta wa⦄⇘i⇙"
"⦃thread_action'_to_thread_action (InterruptAction ia) ta⦄⇘i⇙ = ⦃ta_update_interrupt ta ia⦄⇘i⇙"
"⦃thread_action'_to_thread_action (ObsAction ob) ta⦄⇘i⇙ = ⦃ta_update_obs ta ob⦄⇘i⇙"
and thread_action'_to_thread_action_proj_obs_simps:
"⦃thread_action'_to_thread_action (LockAction (la, l)) ta⦄⇘o⇙ = ⦃ta_update_locks ta la l⦄⇘o⇙"
"⦃thread_action'_to_thread_action (NewThreadAction nt) ta⦄⇘o⇙ = ⦃ta_update_NewThread ta nt⦄⇘o⇙"
"⦃thread_action'_to_thread_action (ConditionalAction ca) ta⦄⇘o⇙ = ⦃ta_update_Conditional ta ca⦄⇘o⇙"
"⦃thread_action'_to_thread_action (WaitSetAction wa) ta⦄⇘o⇙ = ⦃ta_update_wait_set ta wa⦄⇘o⇙"
"⦃thread_action'_to_thread_action (InterruptAction ia) ta⦄⇘o⇙ = ⦃ta_update_interrupt ta ia⦄⇘o⇙"
"⦃thread_action'_to_thread_action (ObsAction ob) ta⦄⇘o⇙ = ⦃ta_update_obs ta ob⦄⇘o⇙"
by(simp_all)
lemmas ta_upd_simps =
ta_update_locks.simps ta_update_NewThread.simps ta_update_Conditional.simps
ta_update_wait_set.simps ta_update_interrupt.simps ta_update_obs.simps
thread_action'_to_thread_action.simps
declare ta_upd_simps [simp del]
hide_const (open)
LockAction NewThreadAction ConditionalAction WaitSetAction InterruptAction ObsAction
thread_action'_to_thread_action
hide_type (open) thread_action'
datatype wake_up_status =
WSNotified
| WSWokenUp
datatype 'w wait_set_status =
InWS 'w
| PostWS wake_up_status
type_synonym 't lock = "('t × nat) option"
type_synonym ('l,'t) locks = "'l ⇒f 't lock"
type_synonym 'l released_locks = "'l ⇒f nat"
type_synonym ('l,'t,'x) thread_info = "'t ⇀ ('x × 'l released_locks)"
type_synonym ('w,'t) wait_sets = "'t ⇀ 'w wait_set_status"
type_synonym 't interrupts = "'t set"
type_synonym ('l,'t,'x,'m,'w) state = "('l,'t) locks × (('l,'t,'x) thread_info × 'm) × ('w,'t) wait_sets × 't interrupts"
translations
(type) "('l, 't) locks" <= (type) "'l ⇒f ('t × nat) option"
(type) "('l, 't, 'x) thread_info" <= (type) "'t ⇀ ('x × ('l ⇒f nat))"
print_translation ‹
let
fun tr'
[Const (@{type_syntax finfun}, _) $ l1 $
(Const (@{type_syntax option}, _) $
(Const (@{type_syntax "prod"}, _) $ t1 $ Const (@{type_syntax nat}, _))),
Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax fun}, _) $ t2 $
(Const (@{type_syntax option}, _) $
(Const (@{type_syntax "prod"}, _) $ x $
(Const (@{type_syntax finfun}, _) $ l2 $ Const (@{type_syntax nat}, _))))) $
m) $
(Const (@{type_syntax prod}, _) $
(Const (@{type_syntax fun}, _) $ t3 $
(Const (@{type_syntax option}, _) $ (Const (@{type_syntax wait_set_status}, _) $ w))) $
(Const (@{type_syntax fun}, _) $ t4 $ (Const (@{type_syntax bool}, _))))] =
if t1 = t2 andalso t1 = t3 andalso t1 = t4 andalso l1 = l2
then Syntax.const @{type_syntax state} $ l1 $ t1 $ x $ m $ w
else raise Match;
in [(@{type_syntax "prod"}, K tr')]
end
›
typ "('l,'t,'x,'m,'w) state"
abbreviation no_wait_locks :: "'l ⇒f nat"
where "no_wait_locks ≡ (K$ 0)"
lemma neq_no_wait_locks_conv:
"⋀ln. ln ≠ no_wait_locks ⟷ (∃l. ln $ l > 0)"
by(auto simp add: expand_finfun_eq fun_eq_iff)
lemma neq_no_wait_locksE:
fixes ln assumes "ln ≠ no_wait_locks" obtains l where "ln $ l > 0"
using assms
by(auto simp add: neq_no_wait_locks_conv)
text ‹
Use type variables for components instead of @{typ "('l,'t,'x,'m,'w) state"} in types for state projections
to allow to reuse them for refined state implementations for code generation.
›
definition locks :: "('locks × ('thread_info × 'm) × 'wsets × 'interrupts) ⇒ 'locks" where
"locks lstsmws ≡ fst lstsmws"
definition thr :: "('locks × ('thread_info × 'm) × 'wsets × 'interrupts) ⇒ 'thread_info" where
"thr lstsmws ≡ fst (fst (snd lstsmws))"
definition shr :: "('locks × ('thread_info × 'm) × 'wsets × 'interrupts) ⇒ 'm" where
"shr lstsmws ≡ snd (fst (snd lstsmws))"
definition wset :: "('locks × ('thread_info × 'm) × 'wsets × 'interrupts) ⇒ 'wsets" where
"wset lstsmws ≡ fst (snd (snd lstsmws))"
definition interrupts :: "('locks × ('thread_info × 'm) × 'wsets × 'interrupts) ⇒ 'interrupts" where
"interrupts lstsmws ≡ snd (snd (snd lstsmws))"
lemma locks_conv [simp]: "locks (ls, tsmws) = ls"
by(simp add: locks_def)
lemma thr_conv [simp]: "thr (ls, (ts, m), ws) = ts"
by(simp add: thr_def)
lemma shr_conv [simp]: "shr (ls, (ts, m), ws, is) = m"
by(simp add: shr_def)
lemma wset_conv [simp]: "wset (ls, (ts, m), ws, is) = ws"
by(simp add: wset_def)
lemma interrupts_conv [simp]: "interrupts (ls, (ts, m), ws, is) = is"
by(simp add: interrupts_def)
primrec convert_new_thread_action :: "('x ⇒ 'x') ⇒ ('t,'x,'m) new_thread_action ⇒ ('t,'x','m) new_thread_action"
where
"convert_new_thread_action f (NewThread t x m) = NewThread t (f x) m"
| "convert_new_thread_action f (ThreadExists t b) = ThreadExists t b"
lemma convert_new_thread_action_inv [simp]:
"NewThread t x h = convert_new_thread_action f nta ⟷ (∃x'. nta = NewThread t x' h ∧ x = f x')"
"ThreadExists t b = convert_new_thread_action f nta ⟷ nta = ThreadExists t b"
"convert_new_thread_action f nta = NewThread t x h ⟷ (∃x'. nta = NewThread t x' h ∧ x = f x')"
"convert_new_thread_action f nta = ThreadExists t b ⟷ nta = ThreadExists t b"
by(cases nta, auto)+
lemma convert_new_thread_action_eqI:
"⟦ ⋀t x m. nta = NewThread t x m ⟹ nta' = NewThread t (f x) m;
⋀t b. nta = ThreadExists t b ⟹ nta' = ThreadExists t b ⟧
⟹ convert_new_thread_action f nta = nta'"
apply(cases nta)
apply fastforce+
done
lemma convert_new_thread_action_compose [simp]:
"convert_new_thread_action f (convert_new_thread_action g ta) = convert_new_thread_action (f o g) ta"
apply(cases ta)
apply(simp_all add: convert_new_thread_action_def)
done
lemma inj_convert_new_thread_action [simp]:
"inj (convert_new_thread_action f) = inj f"
apply(rule iffI)
apply(rule injI)
apply(drule_tac x="NewThread undefined x undefined" in injD)
apply auto[2]
apply(rule injI)
apply(case_tac x)
apply(auto dest: injD)
done
lemma convert_new_thread_action_id:
"convert_new_thread_action id = (id :: ('t, 'x, 'm) new_thread_action ⇒ ('t, 'x, 'm) new_thread_action)" (is ?thesis1)
"convert_new_thread_action (λx. x) = (id :: ('t, 'x, 'm) new_thread_action ⇒ ('t, 'x, 'm) new_thread_action)" (is ?thesis2)
proof -
show ?thesis1 by(rule ext)(case_tac x, simp_all)
thus ?thesis2 by(simp add: id_def)
qed
definition convert_extTA :: "('x ⇒ 'x') ⇒ ('l,'t,'x,'m,'w,'o) thread_action ⇒ ('l,'t,'x','m,'w,'o) thread_action"
where "convert_extTA f ta = (⦃ta⦄⇘l⇙, map (convert_new_thread_action f) ⦃ta⦄⇘t⇙, snd (snd ta))"
lemma convert_extTA_simps [simp]:
"convert_extTA f ε = ε"
"⦃convert_extTA f ta⦄⇘l⇙ = ⦃ta⦄⇘l⇙"
"⦃convert_extTA f ta⦄⇘t⇙ = map (convert_new_thread_action f) ⦃ta⦄⇘t⇙"
"⦃convert_extTA f ta⦄⇘c⇙ = ⦃ta⦄⇘c⇙"
"⦃convert_extTA f ta⦄⇘w⇙ = ⦃ta⦄⇘w⇙"
"⦃convert_extTA f ta⦄⇘i⇙ = ⦃ta⦄⇘i⇙"
"convert_extTA f (las, tas, was, cas, is, obs) = (las, map (convert_new_thread_action f) tas, was, cas, is, obs)"
apply(simp_all add: convert_extTA_def)
apply(cases ta, simp)+
done
lemma convert_extTA_eq_conv:
"convert_extTA f ta = ta' ⟷
⦃ta⦄⇘l⇙ = ⦃ta'⦄⇘l⇙ ∧ ⦃ta⦄⇘c⇙ = ⦃ta'⦄⇘c⇙ ∧ ⦃ta⦄⇘w⇙ = ⦃ta'⦄⇘w⇙ ∧ ⦃ta⦄⇘o⇙ = ⦃ta'⦄⇘o⇙ ∧ ⦃ta⦄⇘i⇙ = ⦃ta'⦄⇘i⇙ ∧ length ⦃ta⦄⇘t⇙ = length ⦃ta'⦄⇘t⇙ ∧
(∀n < length ⦃ta⦄⇘t⇙. convert_new_thread_action f (⦃ta⦄⇘t⇙ ! n) = ⦃ta'⦄⇘t⇙ ! n)"
apply(cases ta, cases ta')
apply(auto simp add: convert_extTA_def map_eq_all_nth_conv)
done
lemma convert_extTA_compose [simp]:
"convert_extTA f (convert_extTA g ta) = convert_extTA (f o g) ta"
by(simp add: convert_extTA_def)
lemma obs_a_convert_extTA [simp]: "obs_a (convert_extTA f ta) = obs_a ta"
by(cases ta) simp
text ‹Actions for thread start/finish›
datatype 'o action =
NormalAction 'o
| InitialThreadAction
| ThreadFinishAction
instance action :: (type) obs_action
proof qed
definition convert_obs_initial :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ ('l,'t,'x,'m,'w,'o action) thread_action"
where
"convert_obs_initial ta = (⦃ta⦄⇘l⇙, ⦃ta⦄⇘t⇙, ⦃ta⦄⇘c⇙, ⦃ta⦄⇘w⇙, ⦃ta⦄⇘i⇙, map NormalAction ⦃ta⦄⇘o⇙)"
lemma inj_NormalAction [simp]: "inj NormalAction"
by(rule injI) auto
lemma convert_obs_initial_inject [simp]:
"convert_obs_initial ta = convert_obs_initial ta' ⟷ ta = ta'"
by(cases ta)(cases ta', auto simp add: convert_obs_initial_def)
lemma convert_obs_initial_empty_TA [simp]:
"convert_obs_initial ε = ε"
by(simp add: convert_obs_initial_def)
lemma convert_obs_initial_eq_empty_TA [simp]:
"convert_obs_initial ta = ε ⟷ ta = ε"
"ε = convert_obs_initial ta ⟷ ta = ε"
by(case_tac [!] ta)(auto simp add: convert_obs_initial_def)
lemma convert_obs_initial_simps [simp]:
"⦃convert_obs_initial ta⦄⇘o⇙ = map NormalAction ⦃ta⦄⇘o⇙"
"⦃convert_obs_initial ta⦄⇘l⇙ = ⦃ta⦄⇘l⇙"
"⦃convert_obs_initial ta⦄⇘t⇙ = ⦃ta⦄⇘t⇙"
"⦃convert_obs_initial ta⦄⇘c⇙ = ⦃ta⦄⇘c⇙"
"⦃convert_obs_initial ta⦄⇘w⇙ = ⦃ta⦄⇘w⇙"
"⦃convert_obs_initial ta⦄⇘i⇙ = ⦃ta⦄⇘i⇙"
by(simp_all add: convert_obs_initial_def)
type_synonym
('l,'t,'x,'m,'w,'o) semantics =
"'t ⇒ 'x × 'm ⇒ ('l,'t,'x,'m,'w,'o) thread_action ⇒ 'x × 'm ⇒ bool"
print_translation ‹
let
fun tr'
[t4,
Const (@{type_syntax fun}, _) $
(Const (@{type_syntax "prod"}, _) $ x1 $ m1) $
(Const (@{type_syntax fun}, _) $
(Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax finfun}, _) $ l $
(Const (@{type_syntax list}, _) $ Const (@{type_syntax lock_action}, _))) $
(Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax list}, _) $ (Const (@{type_syntax new_thread_action}, _) $ t1 $ x2 $ m2)) $
(Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax list}, _) $ (Const (@{type_syntax conditional_action}, _) $ t2)) $
(Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax list}, _) $ (Const (@{type_syntax wait_set_action}, _) $ t3 $ w)) $
(Const (@{type_syntax prod}, _) $
(Const (@{type_syntax list}, _) $ (Const (@{type_syntax interrupt_action}, _) $ t5)) $
(Const (@{type_syntax list}, _) $ o1)))))) $
(Const (@{type_syntax fun}, _) $ (Const (@{type_syntax "prod"}, _) $ x3 $ m3) $
Const (@{type_syntax bool}, _)))] =
if x1 = x2 andalso x1 = x3 andalso m1 = m2 andalso m1 = m3
andalso t1 = t2 andalso t2 = t3 andalso t3 = t4 andalso t4 = t5
then Syntax.const @{type_syntax semantics} $ l $ t1 $ x1 $ m1 $ w $ o1
else raise Match;
in [(@{type_syntax fun}, K tr')]
end
›
typ "('l,'t,'x,'m,'w,'o) semantics"
end
Theory FWLock
section ‹All about a managing a single lock›
theory FWLock
imports
FWState
begin
fun has_locks :: "'t lock ⇒ 't ⇒ nat" where
"has_locks None t = 0"
| "has_locks ⌊(t', n)⌋ t = (if t = t' then Suc n else 0)"
lemma has_locks_iff:
"has_locks l t = n ⟷
(l = None ∧ n = 0) ∨
(∃n'. l = ⌊(t, n')⌋ ∧ Suc n' = n) ∨ (∃t' n'. l = ⌊(t', n')⌋ ∧ t' ≠ t ∧ n = 0)"
by(cases l, auto)
lemma has_locksE:
"⟦ has_locks l t = n;
⟦ l = None; n = 0 ⟧ ⟹ P;
⋀n'. ⟦ l = ⌊(t, n')⌋; Suc n' = n ⟧ ⟹ P;
⋀t' n'. ⟦ l = ⌊(t', n')⌋; t' ≠ t; n = 0 ⟧ ⟹ P ⟧
⟹ P"
by(auto simp add: has_locks_iff split: if_split_asm prod.split_asm)
inductive may_lock :: "'t lock ⇒ 't ⇒ bool" where
"may_lock None t"
| "may_lock ⌊(t, n)⌋ t"
lemma may_lock_iff [code]:
"may_lock l t = (case l of None ⇒ True | ⌊(t', n)⌋ ⇒ t = t')"
by(auto intro: may_lock.intros elim: may_lock.cases)
lemma may_lockI:
"l = None ∨ (∃n. l = ⌊(t, n)⌋) ⟹ may_lock l t"
by(cases l, auto intro: may_lock.intros)
lemma may_lockE [consumes 1, case_names None Locked]:
"⟦ may_lock l t; l = None ⟹ P; ⋀n. l = ⌊(t, n)⌋ ⟹ P ⟧ ⟹ P"
by(auto elim: may_lock.cases)
lemma may_lock_may_lock_t_eq:
"⟦ may_lock l t; may_lock l t' ⟧ ⟹ (l = None) ∨ (t = t')"
by(auto elim!: may_lockE)
abbreviation has_lock :: "'t lock ⇒ 't ⇒ bool"
where "has_lock l t ≡ 0 < has_locks l t"
lemma has_locks_Suc_has_lock:
"has_locks l t = Suc n ⟹ has_lock l t"
by(auto)
lemmas has_lock_has_locks_Suc = gr0_implies_Suc[where n = "has_locks l t"] for l t
lemma has_lock_has_locks_conv:
"has_lock l t ⟷ (∃n. has_locks l t = (Suc n))"
by(auto intro: has_locks_Suc_has_lock has_lock_has_locks_Suc)
lemma has_lock_may_lock:
"has_lock l t ⟹ may_lock l t"
by(cases l, auto intro: may_lockI)
lemma has_lock_may_lock_t_eq:
"⟦ has_lock l t; may_lock l t' ⟧ ⟹ t = t'"
by(auto elim!: may_lockE split: if_split_asm)
lemma has_locks_has_locks_t_eq:
"⟦has_locks l t = Suc n; has_locks l t' = Suc n'⟧ ⟹ t = t'"
by(auto elim: has_locksE)
lemma has_lock_has_lock_t_eq:
"⟦ has_lock l t; has_lock l t' ⟧ ⟹ t = t'"
unfolding has_lock_has_locks_conv
by(auto intro: has_locks_has_locks_t_eq)
lemma not_may_lock_conv:
"¬ may_lock l t ⟷ (∃t'. t' ≠ t ∧ has_lock l t')"
by(cases l, auto intro: may_lock.intros elim: may_lockE)
fun lock_lock :: "'t lock ⇒ 't ⇒ 't lock" where
"lock_lock None t = ⌊(t, 0)⌋"
| "lock_lock ⌊(t', n)⌋ t = ⌊(t', Suc n)⌋"
fun unlock_lock :: "'t lock ⇒ 't lock" where
"unlock_lock None = None"
| "unlock_lock ⌊(t, n)⌋ = (case n of 0 ⇒ None | Suc n' ⇒ ⌊(t, n')⌋)"
fun release_all :: "'t lock ⇒ 't ⇒ 't lock" where
"release_all None t = None"
| "release_all ⌊(t', n)⌋ t = (if t = t' then None else ⌊(t', n)⌋)"
fun acquire_locks :: "'t lock ⇒ 't ⇒ nat ⇒ 't lock" where
"acquire_locks L t 0 = L"
| "acquire_locks L t (Suc m) = acquire_locks (lock_lock L t) t m"
lemma acquire_locks_conv:
"acquire_locks L t n = (case L of None ⇒ (case n of 0 ⇒ None | Suc m ⇒ ⌊(t, m)⌋) | ⌊(t', m)⌋ ⇒ ⌊(t', n + m)⌋)"
by(induct n arbitrary: L)(auto)
lemma lock_lock_ls_Some:
"∃t' n. lock_lock l t = ⌊(t', n)⌋"
by(cases l, auto)
lemma unlock_lock_SomeD:
"unlock_lock l = ⌊(t', n)⌋ ⟹ l = ⌊(t', Suc n)⌋"
by(cases l, auto split: nat.split_asm)
lemma has_locks_Suc_lock_lock_has_locks_Suc_Suc:
"has_locks l t = Suc n ⟹ has_locks (lock_lock l t) t = Suc (Suc n)"
by(auto elim!: has_locksE)
lemma has_locks_lock_lock_conv [simp]:
"may_lock l t ⟹ has_locks (lock_lock l t) t = Suc (has_locks l t)"
by(auto elim: may_lockE)
lemma has_locks_release_all_conv [simp]:
"has_locks (release_all l t) t = 0"
by(cases l, auto split: if_split_asm)
lemma may_lock_lock_lock_conv [simp]: "may_lock (lock_lock l t) t = may_lock l t"
by(cases l, auto elim!: may_lock.cases intro: may_lock.intros)
lemma has_locks_acquire_locks_conv [simp]:
"may_lock l t ⟹ has_locks (acquire_locks l t n) t = has_locks l t + n"
by(induct n arbitrary: l, auto)
lemma may_lock_unlock_lock_conv [simp]:
"has_lock l t ⟹ may_lock (unlock_lock l) t = may_lock l t"
by(cases l)(auto split: if_split_asm nat.splits elim!: may_lock.cases intro: may_lock.intros)
lemma may_lock_release_all_conv [simp]:
"may_lock (release_all l t) t = may_lock l t"
by(cases l, auto split: if_split_asm intro!: may_lockI elim: may_lockE)
lemma may_lock_t_may_lock_unlock_lock_t:
"may_lock l t ⟹ may_lock (unlock_lock l) t"
by(auto intro: may_lock.intros elim!: may_lockE split: nat.split)
lemma may_lock_has_locks_lock_lock_0:
"⟦may_lock l t'; t ≠ t'⟧ ⟹ has_locks (lock_lock l t') t = 0"
by(auto elim!: may_lock.cases)
lemma has_locks_unlock_lock_conv [simp]:
"has_lock l t ⟹ has_locks (unlock_lock l) t = has_locks l t - 1"
by(cases l)(auto split: nat.split)
lemma has_lock_lock_lock_unlock_lock_id [simp]:
"has_lock l t ⟹ lock_lock (unlock_lock l) t = l"
by(cases l)(auto split: if_split_asm nat.split)
lemma may_lock_unlock_lock_lock_lock_id [simp]:
"may_lock l t ⟹ unlock_lock (lock_lock l t) = l"
by(cases l) auto
lemma may_lock_has_locks_0:
"⟦ may_lock l t; t ≠ t' ⟧ ⟹ has_locks l t' = 0"
by(auto elim!: may_lockE)
fun upd_lock :: "'t lock ⇒ 't ⇒ lock_action ⇒ 't lock"
where
"upd_lock l t Lock = lock_lock l t"
| "upd_lock l t Unlock = unlock_lock l"
| "upd_lock l t UnlockFail = l"
| "upd_lock l t ReleaseAquire = release_all l t"
fun upd_locks :: "'t lock ⇒ 't ⇒ lock_action list ⇒ 't lock"
where
"upd_locks l t [] = l"
| "upd_locks l t (L # Ls) = upd_locks (upd_lock l t L) t Ls"
lemma upd_locks_append [simp]:
"upd_locks l t (Ls @ Ls') = upd_locks (upd_locks l t Ls) t Ls'"
by(induct Ls arbitrary: l, auto)
lemma upd_lock_Some_thread_idD:
assumes ul: "upd_lock l t L = ⌊(t', n)⌋"
and tt': "t ≠ t'"
shows "∃n. l = ⌊(t', n)⌋"
proof(cases L)
case Lock
with ul tt' show ?thesis
by(cases l, auto)
next
case Unlock
with ul tt' show ?thesis
by(auto dest: unlock_lock_SomeD)
next
case UnlockFail
with ul show ?thesis by(simp)
next
case ReleaseAcquire
with ul show ?thesis
by(cases l, auto split: if_split_asm)
qed
lemma has_lock_upd_lock_implies_has_lock:
"⟦ has_lock (upd_lock l t L) t'; t ≠ t' ⟧ ⟹ has_lock l t'"
by(cases l L rule: option.exhaust[case_product lock_action.exhaust])(auto split: if_split_asm nat.split_asm)
lemma has_lock_upd_locks_implies_has_lock:
"⟦ has_lock (upd_locks l t Ls) t'; t ≠ t' ⟧ ⟹ has_lock l t'"
by(induct l t Ls rule: upd_locks.induct)(auto intro: has_lock_upd_lock_implies_has_lock)
fun lock_action_ok :: "'t lock ⇒ 't ⇒ lock_action ⇒ bool" where
"lock_action_ok l t Lock = may_lock l t"
| "lock_action_ok l t Unlock = has_lock l t"
| "lock_action_ok l t UnlockFail = (¬ has_lock l t)"
| "lock_action_ok l t ReleaseAcquire = True"
fun lock_actions_ok :: "'t lock ⇒ 't ⇒ lock_action list ⇒ bool" where
"lock_actions_ok l t [] = True"
| "lock_actions_ok l t (L # Ls) = (lock_action_ok l t L ∧ lock_actions_ok (upd_lock l t L) t Ls)"
lemma lock_actions_ok_append [simp]:
"lock_actions_ok l t (Ls @ Ls') ⟷ lock_actions_ok l t Ls ∧ lock_actions_ok (upd_locks l t Ls) t Ls'"
by(induct Ls arbitrary: l) auto
lemma not_lock_action_okE [consumes 1, case_names Lock Unlock UnlockFail]:
"⟦ ¬ lock_action_ok l t L;
⟦ L = Lock; ¬ may_lock l t ⟧ ⟹ Q;
⟦ L = Unlock; ¬ has_lock l t ⟧ ⟹ Q;
⟦ L = UnlockFail; has_lock l t ⟧ ⟹ Q⟧
⟹ Q"
by(cases L) auto
lemma may_lock_upd_lock_conv [simp]:
"lock_action_ok l t L ⟹ may_lock (upd_lock l t L) t = may_lock l t"
by(cases L) auto
lemma may_lock_upd_locks_conv [simp]:
"lock_actions_ok l t Ls ⟹ may_lock (upd_locks l t Ls) t = may_lock l t"
by(induct l t Ls rule: upd_locks.induct) simp_all
lemma lock_actions_ok_Lock_may_lock:
"⟦ lock_actions_ok l t Ls; Lock ∈ set Ls ⟧ ⟹ may_lock l t"
by(induct l t Ls rule: lock_actions_ok.induct) auto
lemma has_locks_lock_lock_conv' [simp]:
"⟦ may_lock l t'; t ≠ t' ⟧ ⟹ has_locks (lock_lock l t') t = has_locks l t"
by(cases l)(auto elim: may_lock.cases)
lemma has_locks_unlock_lock_conv' [simp]:
"⟦ has_lock l t'; t ≠ t' ⟧ ⟹ has_locks (unlock_lock l) t = has_locks l t"
by(cases l)(auto split: if_split_asm nat.split)
lemma has_locks_release_all_conv' [simp]:
"t ≠ t' ⟹ has_locks (release_all l t') t = has_locks l t"
by(cases l) auto
lemma has_locks_acquire_locks_conv' [simp]:
"⟦ may_lock l t; t ≠ t' ⟧ ⟹ has_locks (acquire_locks l t n) t' = has_locks l t'"
by(induct l t n rule: acquire_locks.induct) simp_all
lemma lock_action_ok_has_locks_upd_lock_eq_has_locks [simp]:
"⟦ lock_action_ok l t' L; t ≠ t' ⟧ ⟹ has_locks (upd_lock l t' L) t = has_locks l t"
by(cases L) auto
lemma lock_actions_ok_has_locks_upd_locks_eq_has_locks [simp]:
"⟦ lock_actions_ok l t' Ls; t ≠ t' ⟧ ⟹ has_locks (upd_locks l t' Ls) t = has_locks l t"
by(induct l t' Ls rule: upd_locks.induct) simp_all
lemma has_lock_acquire_locks_implies_has_lock:
"⟦ has_lock (acquire_locks l t n) t'; t ≠ t' ⟧ ⟹ has_lock l t'"
unfolding acquire_locks_conv
by(cases n)(auto split: if_split_asm)
lemma has_lock_has_lock_acquire_locks:
"has_lock l T ⟹ has_lock (acquire_locks l t n) T"
unfolding acquire_locks_conv
by(auto)
fun lock_actions_ok' :: "'t lock ⇒ 't ⇒ lock_action list ⇒ bool" where
"lock_actions_ok' l t [] = True"
| "lock_actions_ok' l t (L#Ls) = ((L = Lock ∧ ¬ may_lock l t) ∨
lock_action_ok l t L ∧ lock_actions_ok' (upd_lock l t L) t Ls)"
lemma lock_actions_ok'_iff:
"lock_actions_ok' l t las ⟷
lock_actions_ok l t las ∨ (∃xs ys. las = xs @ Lock # ys ∧ lock_actions_ok l t xs ∧ ¬ may_lock (upd_locks l t xs) t)"
proof(induct l t las rule: lock_actions_ok.induct)
case (2 L t LA LAS)
show ?case
proof(cases "LA = Lock ∧ ¬ may_lock L t")
case True
hence "(∃ys. Lock # LAS = [] @ Lock # ys) ∧ lock_actions_ok L t [] ∧ ¬ may_lock (upd_locks L t []) t"
by(simp)
with True show ?thesis by(simp (no_asm))(blast)
next
case False
with 2 show ?thesis
by(fastforce simp add: Cons_eq_append_conv elim: allE[where x="LA # xs" for xs])
qed
qed simp
lemma lock_actions_ok'E[consumes 1, case_names ok Lock]:
"⟦ lock_actions_ok' l t las;
lock_actions_ok l t las ⟹ P;
⋀xs ys. ⟦ las = xs @ Lock # ys; lock_actions_ok l t xs; ¬ may_lock (upd_locks l t xs) t ⟧ ⟹ P ⟧
⟹ P"
by(auto simp add: lock_actions_ok'_iff)
end
Theory FWLocking
section ‹Semantics of the thread actions for locking›
theory FWLocking
imports
FWLock
begin
definition redT_updLs :: "('l,'t) locks ⇒ 't ⇒ 'l lock_actions ⇒ ('l,'t) locks" where
"redT_updLs ls t las ≡ (λ(l, la). upd_locks l t la) ∘$ (($ls, las$))"
lemma redT_updLs_iff [simp]: "redT_updLs ls t las $ l = upd_locks (ls $ l) t (las $ l)"
by(simp add: redT_updLs_def)
lemma upd_locks_empty_conv [simp]: "(λ(l, las). upd_locks l t las) ∘$ ($ls, K$ []$) = ls"
by(auto intro: finfun_ext)
lemma redT_updLs_Some_thread_idD:
"⟦ has_lock (redT_updLs ls t las $ l) t'; t ≠ t' ⟧ ⟹ has_lock (ls $ l) t'"
by(auto simp add: redT_updLs_def intro: has_lock_upd_locks_implies_has_lock)
definition acquire_all :: "('l, 't) locks ⇒ 't ⇒ ('l ⇒f nat) ⇒ ('l, 't) locks"
where "⋀ln. acquire_all ls t ln ≡ (λ(l, la). acquire_locks l t la) ∘$ (($ls, ln$))"
lemma acquire_all_iff [simp]:
"⋀ln. acquire_all ls t ln $ l = acquire_locks (ls $ l) t (ln $ l)"
by(simp add: acquire_all_def)
definition lock_ok_las :: "('l,'t) locks ⇒ 't ⇒ 'l lock_actions ⇒ bool" where
"lock_ok_las ls t las ≡ ∀l. lock_actions_ok (ls $ l) t (las $ l)"
lemma lock_ok_lasI [intro]:
"(⋀l. lock_actions_ok (ls $ l) t (las $ l)) ⟹ lock_ok_las ls t las"
by(simp add: lock_ok_las_def)
lemma lock_ok_lasE:
"⟦ lock_ok_las ls t las; (⋀l. lock_actions_ok (ls $ l) t (las $ l)) ⟹ Q ⟧ ⟹ Q"
by(simp add: lock_ok_las_def)
lemma lock_ok_lasD:
"lock_ok_las ls t las ⟹ lock_actions_ok (ls $ l) t (las $ l)"
by(simp add: lock_ok_las_def)
lemma lock_ok_las_code [code]:
"lock_ok_las ls t las = finfun_All ((λ(l, la). lock_actions_ok l t la) ∘$ ($ls, las$))"
by(simp add: lock_ok_las_def finfun_All_All o_def)
lemma lock_ok_las_may_lock:
"⟦ lock_ok_las ls t las; Lock ∈ set (las $ l) ⟧ ⟹ may_lock (ls $ l) t"
by(erule lock_ok_lasE)(rule lock_actions_ok_Lock_may_lock)
lemma redT_updLs_may_lock [simp]:
"lock_ok_las ls t las ⟹ may_lock (redT_updLs ls t las $ l) t = may_lock (ls $ l) t"
by(auto dest!: lock_ok_lasD[where l=l])
lemma redT_updLs_has_locks [simp]:
"⟦ lock_ok_las ls t' las; t ≠ t' ⟧ ⟹ has_locks (redT_updLs ls t' las $ l) t = has_locks (ls $ l) t"
by(auto dest!: lock_ok_lasD[where l=l])
definition may_acquire_all :: "('l, 't) locks ⇒ 't ⇒ ('l ⇒f nat) ⇒ bool"
where "⋀ln. may_acquire_all ls t ln ≡ ∀l. ln $ l > 0 ⟶ may_lock (ls $ l) t"
lemma may_acquire_allI [intro]:
"⋀ln. (⋀l. ln $ l > 0 ⟹ may_lock (ls $ l) t) ⟹ may_acquire_all ls t ln"
by(simp add: may_acquire_all_def)
lemma may_acquire_allE:
"⋀ln. ⟦ may_acquire_all ls t ln; ∀l. ln $ l > 0 ⟶ may_lock (ls $ l) t ⟹ P ⟧ ⟹ P"
by(auto simp add: may_acquire_all_def)
lemma may_acquire_allD [dest]:
"⋀ln. ⟦ may_acquire_all ls t ln; ln $ l > 0 ⟧ ⟹ may_lock (ls $ l) t"
by(auto simp add: may_acquire_all_def)
lemma may_acquire_all_has_locks_acquire_locks [simp]:
fixes ln
shows "⟦ may_acquire_all ls t ln; t ≠ t' ⟧ ⟹ has_locks (acquire_locks (ls $ l) t (ln $ l)) t' = has_locks (ls $ l) t'"
by(cases "ln $ l > 0")(auto dest: may_acquire_allD)
lemma may_acquire_all_code [code]:
"⋀ln. may_acquire_all ls t ln ⟷ finfun_All ((λ(lock, n). n > 0 ⟶ may_lock lock t) ∘$ ($ls, ln$))"
by(auto simp add: may_acquire_all_def finfun_All_All o_def)
definition collect_locks :: "'l lock_actions ⇒ 'l set" where
"collect_locks las = {l. Lock ∈ set (las $ l)}"
lemma collect_locksI:
"Lock ∈ set (las $ l) ⟹ l ∈ collect_locks las"
by(simp add: collect_locks_def)
lemma collect_locksE:
"⟦ l ∈ collect_locks las; Lock ∈ set (las $ l) ⟹ P ⟧ ⟹ P"
by(simp add: collect_locks_def)
lemma collect_locksD:
"l ∈ collect_locks las ⟹ Lock ∈ set (las $ l)"
by(simp add: collect_locks_def)
fun must_acquire_lock :: "lock_action list ⇒ bool" where
"must_acquire_lock [] = False"
| "must_acquire_lock (Lock # las) = True"
| "must_acquire_lock (Unlock # las) = False"
| "must_acquire_lock (_ # las) = must_acquire_lock las"
lemma must_acquire_lock_append:
"must_acquire_lock (xs @ ys) ⟷ (if Lock ∈ set xs ∨ Unlock ∈ set xs then must_acquire_lock xs else must_acquire_lock ys)"
proof(induct xs)
case Nil thus ?case by simp
next
case (Cons L Ls)
thus ?case by (cases L, simp_all)
qed
lemma must_acquire_lock_contains_lock:
"must_acquire_lock las ⟹ Lock ∈ set las"
proof(induct las)
case (Cons l las) thus ?case by(cases l) auto
qed simp
lemma must_acquire_lock_conv:
"must_acquire_lock las = (case (filter (λL. L = Lock ∨ L = Unlock) las) of [] ⇒ False | L # Ls ⇒ L = Lock)"
proof(induct las)
case Nil thus ?case by simp
next
case (Cons LA LAS) thus ?case
by(cases LA, auto split: list.split_asm)
qed
definition collect_locks' :: "'l lock_actions ⇒ 'l set" where
"collect_locks' las ≡ {l. must_acquire_lock (las $ l)}"
lemma collect_locks'I:
"must_acquire_lock (las $ l) ⟹ l ∈ collect_locks' las"
by(simp add: collect_locks'_def)
lemma collect_locks'E:
"⟦ l ∈ collect_locks' las; must_acquire_lock (las $ l) ⟹ P ⟧ ⟹ P"
by(simp add: collect_locks'_def)
lemma collect_locks'_subset_collect_locks:
"collect_locks' las ⊆ collect_locks las"
by(auto simp add: collect_locks'_def collect_locks_def intro: must_acquire_lock_contains_lock)
definition lock_ok_las' :: "('l,'t) locks ⇒ 't ⇒ 'l lock_actions ⇒ bool" where
"lock_ok_las' ls t las ≡ ∀l. lock_actions_ok' (ls $ l) t (las $ l)"
lemma lock_ok_las'I: "(⋀l. lock_actions_ok' (ls $ l) t (las $ l)) ⟹ lock_ok_las' ls t las"
by(simp add: lock_ok_las'_def)
lemma lock_ok_las'D: "lock_ok_las' ls t las ⟹ lock_actions_ok' (ls $ l) t (las $ l)"
by(simp add: lock_ok_las'_def)
lemma not_lock_ok_las'_conv:
"¬ lock_ok_las' ls t las ⟷ (∃l. ¬ lock_actions_ok' (ls $ l) t (las $ l))"
by(simp add: lock_ok_las'_def)
lemma lock_ok_las'_code:
"lock_ok_las' ls t las = finfun_All ((λ(l, la). lock_actions_ok' l t la) ∘$ ($ls, las$))"
by(simp add: lock_ok_las'_def finfun_All_All o_def)
lemma lock_ok_las'_collect_locks'_may_lock:
assumes lot': "lock_ok_las' ls t las"
and mayl: "∀l ∈ collect_locks' las. may_lock (ls $ l) t"
and l: "l ∈ collect_locks las"
shows "may_lock (ls $ l) t"
proof(cases "l ∈ collect_locks' las")
case True thus ?thesis using mayl by auto
next
case False
hence nmal: "¬ must_acquire_lock (las $ l)"
by(auto intro: collect_locks'I)
from l have locklasl: "Lock ∈ set (las $ l)"
by(rule collect_locksD)
then obtain ys zs
where las: "las $ l = ys @ Lock # zs"
and notin: "Lock ∉ set ys"
by(auto dest: split_list_first)
from lot' have "lock_actions_ok' (ls $ l) t (las $ l)"
by(auto simp add: lock_ok_las'_def)
thus ?thesis
proof(induct rule: lock_actions_ok'E)
case ok
with locklasl show ?thesis
by -(rule lock_actions_ok_Lock_may_lock)
next
case (Lock YS ZS)
note LAS = ‹las $ l = YS @ Lock # ZS›
note lao = ‹lock_actions_ok (ls $ l) t YS›
note nml = ‹¬ may_lock (upd_locks (ls $ l) t YS) t›
from LAS las nmal notin have "Unlock ∈ set YS"
by -(erule contrapos_np, auto simp add: must_acquire_lock_append append_eq_append_conv2 append_eq_Cons_conv)
then obtain ys' zs'
where YS: "YS = ys' @ Unlock # zs'"
and unlock: "Unlock ∉ set ys'"
by(auto dest: split_list_first)
from YS las LAS lao have lao': "lock_actions_ok (ls $ l) t (ys' @ [Unlock])" by(auto)
hence "has_lock (upd_locks (ls $ l) t ys') t" by simp
hence "may_lock (upd_locks (ls $ l) t ys') t"
by(rule has_lock_may_lock)
moreover from lao' have "lock_actions_ok (ls $ l) t ys'" by simp
ultimately show ?thesis by simp
qed
qed
lemma lock_actions_ok'_must_acquire_lock_lock_actions_ok:
"⟦ lock_actions_ok' l t Ls; must_acquire_lock Ls ⟶ may_lock l t⟧ ⟹ lock_actions_ok l t Ls"
proof(induct l t Ls rule: lock_actions_ok.induct)
case 1 thus ?case by simp
next
case (2 l t L LS) thus ?case
proof(cases "L = Lock ∨ L = Unlock")
case True
with 2 show ?thesis by(auto simp add: lock_actions_ok'_iff Cons_eq_append_conv intro: has_lock_may_lock)
qed(cases L, auto)
qed
lemma lock_ok_las'_collect_locks_lock_ok_las:
assumes lol': "lock_ok_las' ls t las"
and clml: "⋀l. l ∈ collect_locks las ⟹ may_lock (ls $ l) t"
shows "lock_ok_las ls t las"
proof(rule lock_ok_lasI)
fix l
from lol' have "lock_actions_ok' (ls $ l) t (las $ l)" by(rule lock_ok_las'D)
thus "lock_actions_ok (ls $ l) t (las $ l)"
proof(rule lock_actions_ok'_must_acquire_lock_lock_actions_ok[OF _ impI])
assume mal: "must_acquire_lock (las $ l)"
thus "may_lock (ls $ l) t"
by(auto intro!: clml collect_locksI elim: must_acquire_lock_contains_lock )
qed
qed
lemma lock_ok_las'_into_lock_on_las:
"⟦lock_ok_las' ls t las; ⋀l. l ∈ collect_locks' las ⟹ may_lock (ls $ l) t⟧ ⟹ lock_ok_las ls t las"
by (metis lock_ok_las'_collect_locks'_may_lock lock_ok_las'_collect_locks_lock_ok_las)
end
Theory FWThread
section ‹Semantics of the thread actions for thread creation›
theory FWThread
imports
FWState
begin
text‹Abstractions for thread ids›
context
notes [[inductive_internals]]
begin
inductive free_thread_id :: "('l,'t,'x) thread_info ⇒ 't ⇒ bool"
for ts :: "('l,'t,'x) thread_info" and t :: 't
where "ts t = None ⟹ free_thread_id ts t"
declare free_thread_id.cases [elim]
end
lemma free_thread_id_iff: "free_thread_id ts t = (ts t = None)"
by(auto elim: free_thread_id.cases intro: free_thread_id.intros)
text‹Update functions for the multithreaded state›
fun redT_updT :: "('l,'t,'x) thread_info ⇒ ('t,'x,'m) new_thread_action ⇒ ('l,'t,'x) thread_info"
where
"redT_updT ts (NewThread t' x m) = ts(t' ↦ (x, no_wait_locks))"
| "redT_updT ts _ = ts"
fun redT_updTs :: "('l,'t,'x) thread_info ⇒ ('t,'x,'m) new_thread_action list ⇒ ('l,'t,'x) thread_info"
where
"redT_updTs ts [] = ts"
| "redT_updTs ts (ta#tas) = redT_updTs (redT_updT ts ta) tas"
lemma redT_updTs_append [simp]:
"redT_updTs ts (tas @ tas') = redT_updTs (redT_updTs ts tas) tas'"
by(induct ts tas rule: redT_updTs.induct) auto
lemma redT_updT_None:
"redT_updT ts ta t = None ⟹ ts t = None"
by(cases ta)(auto split: if_splits)
lemma redT_updTs_None: "redT_updTs ts tas t = None ⟹ ts t = None"
by(induct ts tas rule: redT_updTs.induct)(auto intro: redT_updT_None)
lemma redT_updT_Some1:
"ts t = ⌊xw⌋ ⟹ ∃xw. redT_updT ts ta t = ⌊xw⌋"
by(cases ta) auto
lemma redT_updTs_Some1:
"ts t = ⌊xw⌋ ⟹ ∃xw. redT_updTs ts tas t = ⌊xw⌋"
unfolding not_None_eq[symmetric]
by(induct ts tas arbitrary: xw rule: redT_updTs.induct)(simp_all del: split_paired_Ex, blast dest: redT_updT_Some1)
lemma redT_updT_finite_dom_inv:
"finite (dom (redT_updT ts ta)) = finite (dom ts)"
by(cases ta) auto
lemma redT_updTs_finite_dom_inv:
"finite (dom (redT_updTs ts tas)) = finite (dom ts)"
by(induct ts tas rule: redT_updTs.induct)(simp_all add: redT_updT_finite_dom_inv)
text‹Preconditions for thread creation actions›
text‹These primed versions are for checking preconditions only. They allow the thread actions to have a type for thread-local information that is different than the thread info state itself.›
fun redT_updT' :: "('l,'t,'x) thread_info ⇒ ('t,'x','m) new_thread_action ⇒ ('l,'t,'x) thread_info"
where
"redT_updT' ts (NewThread t' x m) = ts(t' ↦ (undefined, no_wait_locks))"
| "redT_updT' ts _ = ts"
fun redT_updTs' :: "('l,'t,'x) thread_info ⇒ ('t,'x','m) new_thread_action list ⇒ ('l,'t,'x) thread_info"
where
"redT_updTs' ts [] = ts"
| "redT_updTs' ts (ta#tas) = redT_updTs' (redT_updT' ts ta) tas"
lemma redT_updT'_None:
"redT_updT' ts ta t = None ⟹ ts t = None"
by(cases ta)(auto split: if_splits)
primrec thread_ok :: "('l,'t,'x) thread_info ⇒ ('t,'x','m) new_thread_action ⇒ bool"
where
"thread_ok ts (NewThread t x m) = free_thread_id ts t"
| "thread_ok ts (ThreadExists t b) = (b ≠ free_thread_id ts t)"
fun thread_oks :: "('l,'t,'x) thread_info ⇒ ('t,'x','m) new_thread_action list ⇒ bool"
where
"thread_oks ts [] = True"
| "thread_oks ts (ta#tas) = (thread_ok ts ta ∧ thread_oks (redT_updT' ts ta) tas)"
lemma thread_ok_ts_change:
"(⋀t. ts t = None ⟷ ts' t = None) ⟹ thread_ok ts ta ⟷ thread_ok ts' ta"
by(cases ta)(auto simp add: free_thread_id_iff)
lemma thread_oks_ts_change:
"(⋀t. ts t = None ⟷ ts' t = None) ⟹ thread_oks ts tas ⟷ thread_oks ts' tas"
proof(induct tas arbitrary: ts ts')
case Nil thus ?case by simp
next
case (Cons ta tas ts ts')
note IH = ‹⋀ts ts'. (⋀t. (ts t = None) = (ts' t = None)) ⟹ thread_oks ts tas = thread_oks ts' tas›
note eq = ‹⋀t. (ts t = None) = (ts' t = None)›
from eq have "thread_ok ts ta ⟷ thread_ok ts' ta" by(rule thread_ok_ts_change)
moreover from eq have "⋀t. (redT_updT' ts ta t = None) = (redT_updT' ts' ta t = None)"
by(cases ta)(auto)
hence "thread_oks (redT_updT' ts ta) tas = thread_oks (redT_updT' ts' ta) tas" by(rule IH)
ultimately show ?case by simp
qed
lemma redT_updT'_eq_None_conv:
"(⋀t. ts t = None ⟷ ts' t = None) ⟹ redT_updT' ts ta t = None ⟷ redT_updT ts' ta t = None"
by(cases ta) simp_all
lemma redT_updTs'_eq_None_conv:
"(⋀t. ts t = None ⟷ ts' t = None) ⟹ redT_updTs' ts tas t = None ⟷ redT_updTs ts' tas t = None"
apply(induct tas arbitrary: ts ts')
apply simp_all
apply(blast intro: redT_updT'_eq_None_conv del: iffI)
done
lemma thread_oks_redT_updT_conv [simp]:
"thread_oks (redT_updT' ts ta) tas = thread_oks (redT_updT ts ta) tas"
by(rule thread_oks_ts_change)(rule redT_updT'_eq_None_conv refl)+
lemma thread_oks_append [simp]:
"thread_oks ts (tas @ tas') = (thread_oks ts tas ∧ thread_oks (redT_updTs' ts tas) tas')"
by(induct tas arbitrary: ts, auto)
lemma thread_oks_redT_updTs_conv [simp]:
"thread_oks (redT_updTs' ts ta) tas = thread_oks (redT_updTs ts ta) tas"
by(rule thread_oks_ts_change)(rule redT_updTs'_eq_None_conv refl)+
lemma redT_updT_Some:
"⟦ ts t = ⌊xw⌋; thread_ok ts ta ⟧ ⟹ redT_updT ts ta t = ⌊xw⌋"
by(cases ta) auto
lemma redT_updTs_Some:
"⟦ ts t = ⌊xw⌋; thread_oks ts tas ⟧ ⟹ redT_updTs ts tas t = ⌊xw⌋"
by(induct ts tas rule: redT_updTs.induct)(auto intro: redT_updT_Some)
lemma redT_updT'_Some:
"⟦ ts t = ⌊xw⌋; thread_ok ts ta ⟧ ⟹ redT_updT' ts ta t = ⌊xw⌋"
by(cases ta) auto
lemma redT_updTs'_Some:
"⟦ ts t = ⌊xw⌋; thread_oks ts tas ⟧ ⟹ redT_updTs' ts tas t = ⌊xw⌋"
by(induct ts tas rule: redT_updTs'.induct)(auto intro: redT_updT'_Some)
lemma thread_ok_new_thread:
"thread_ok ts (NewThread t m' x) ⟹ ts t = None"
by(auto)
lemma thread_oks_new_thread:
"⟦ thread_oks ts tas; NewThread t x m ∈ set tas ⟧ ⟹ ts t = None"
by(induct ts tas rule: thread_oks.induct)(auto intro: redT_updT'_None)
lemma redT_updT_new_thread_ts:
"thread_ok ts (NewThread t x m) ⟹ redT_updT ts (NewThread t x m) t = ⌊(x, no_wait_locks)⌋"
by(simp)
lemma redT_updTs_new_thread_ts:
"⟦ thread_oks ts tas; NewThread t x m ∈ set tas ⟧ ⟹ redT_updTs ts tas t = ⌊(x, no_wait_locks)⌋"
by(induct ts tas rule: redT_updTs.induct)(auto intro: redT_updTs_Some)
lemma redT_updT_new_thread:
"⟦ redT_updT ts ta t = ⌊(x, w)⌋; thread_ok ts ta; ts t = None ⟧ ⟹ ∃m. ta = NewThread t x m ∧ w = no_wait_locks"
by(cases ta)(auto split: if_split_asm)
lemma redT_updTs_new_thread:
"⟦ redT_updTs ts tas t = ⌊(x, w)⌋; thread_oks ts tas; ts t = None ⟧
⟹ ∃m .NewThread t x m ∈ set tas ∧ w = no_wait_locks"
proof(induct tas arbitrary: ts)
case Nil thus ?case by simp
next
case (Cons TA TAS TS)
note IH = ‹⋀ts. ⟦redT_updTs ts TAS t = ⌊(x, w)⌋; thread_oks ts TAS; ts t = None⟧ ⟹ ∃m. NewThread t x m ∈ set TAS ∧ w = no_wait_locks›
note es't = ‹redT_updTs TS (TA # TAS) t = ⌊(x, w)⌋›
note cct = ‹thread_oks TS (TA # TAS)›
hence cctta: "thread_ok TS TA" and ccts: "thread_oks (redT_updT TS TA) TAS" by auto
note est = ‹TS t = None›
{ fix X W
assume rest: "redT_updT TS TA t = ⌊(X, W)⌋"
then obtain m where "TA = NewThread t X m ∧ W = no_wait_locks" using cctta est
by (auto dest!: redT_updT_new_thread)
then obtain "TA = NewThread t X m" "W = no_wait_locks" ..
moreover from rest ccts
have "redT_updTs TS (TA # TAS) t = ⌊(X, W)⌋"
by(auto intro:redT_updTs_Some)
with es't have "X = x" "W = w" by auto
ultimately have ?case by auto }
moreover
{ assume rest: "redT_updT TS TA t = None"
hence "⋀m. TA ≠ NewThread t x m" using est cct
by(clarsimp)
with rest ccts es't have ?case by(auto dest: IH) }
ultimately show ?case by(cases "redT_updT TS TA t", auto)
qed
lemma redT_updT_upd:
"⟦ ts t = ⌊xw⌋; thread_ok ts ta ⟧ ⟹ redT_updT ts ta(t ↦ xw') = redT_updT (ts(t ↦ xw')) ta"
by(cases ta)(fastforce intro: fun_upd_twist)+
lemma redT_updTs_upd:
"⟦ ts t = ⌊xw⌋; thread_oks ts tas ⟧ ⟹ redT_updTs ts tas(t ↦ xw') = redT_updTs (ts(t ↦ xw')) tas"
by(induct ts tas rule: redT_updTs.induct)(auto simp del: fun_upd_apply simp add: redT_updT_upd dest: redT_updT_Some)
lemma thread_ok_upd:
"ts t = ⌊xln⌋ ⟹ thread_ok (ts(t ↦ xln')) ta = thread_ok ts ta"
by(rule thread_ok_ts_change) simp
lemma thread_oks_upd:
"ts t = ⌊xln⌋ ⟹ thread_oks (ts(t ↦ xln')) tas = thread_oks ts tas"
by(rule thread_oks_ts_change) simp
lemma thread_ok_convert_new_thread_action [simp]:
"thread_ok ts (convert_new_thread_action f ta) = thread_ok ts ta"
by(cases ta) auto
lemma redT_updT'_convert_new_thread_action_eq_None:
"redT_updT' ts (convert_new_thread_action f ta) t = None ⟷ redT_updT' ts ta t = None"
by(cases ta) auto
lemma thread_oks_convert_new_thread_action [simp]:
"thread_oks ts (map (convert_new_thread_action f) tas) = thread_oks ts tas"
by(induct ts tas rule: thread_oks.induct)(simp_all add: thread_oks_ts_change[OF redT_updT'_convert_new_thread_action_eq_None])
lemma map_redT_updT:
"map_option (map_prod f id) (redT_updT ts ta t) =
redT_updT (λt. map_option (map_prod f id) (ts t)) (convert_new_thread_action f ta) t"
by(cases ta) auto
lemma map_redT_updTs:
"map_option (map_prod f id) (redT_updTs ts tas t) =
redT_updTs (λt. map_option (map_prod f id) (ts t)) (map (convert_new_thread_action f) tas) t"
by(induct tas arbitrary: ts)(auto simp add: map_redT_updT)
end
Theory FWWait
section ‹Semantics of the thread actions for wait, notify and interrupt›
theory FWWait
imports
FWState
begin
text ‹Update functions for the wait sets in the multithreaded state›
inductive redT_updW :: "'t ⇒ ('w, 't) wait_sets ⇒ ('t,'w) wait_set_action ⇒ ('w,'t) wait_sets ⇒ bool"
for t :: 't and ws :: "('w, 't) wait_sets"
where
"ws t' = ⌊InWS w⌋ ⟹ redT_updW t ws (Notify w) (ws(t' ↦ PostWS WSNotified))"
| "(⋀t'. ws t' ≠ ⌊InWS w⌋) ⟹ redT_updW t ws (Notify w) ws"
| "redT_updW t ws (NotifyAll w) (λt. if ws t = ⌊InWS w⌋ then ⌊PostWS WSNotified⌋ else ws t)"
| "redT_updW t ws (Suspend w) (ws(t ↦ InWS w))"
| "ws t' = ⌊InWS w⌋ ⟹ redT_updW t ws (WakeUp t') (ws(t' ↦ PostWS WSInterrupted))"
| "(⋀w. ws t' ≠ ⌊InWS w⌋) ⟹ redT_updW t ws (WakeUp t') ws"
| "redT_updW t ws Notified (ws(t := None))"
| "redT_updW t ws WokenUp (ws(t := None))"
definition redT_updWs :: "'t ⇒ ('w,'t) wait_sets ⇒ ('t,'w) wait_set_action list ⇒ ('w,'t) wait_sets ⇒ bool"
where "redT_updWs t = rtrancl3p (redT_updW t)"
inductive_simps redT_updW_simps [simp]:
"redT_updW t ws (Notify w) ws'"
"redT_updW t ws (NotifyAll w) ws'"
"redT_updW t ws (Suspend w) ws'"
"redT_updW t ws (WakeUp t') ws'"
"redT_updW t ws WokenUp ws'"
"redT_updW t ws Notified ws'"
lemma redT_updW_total: "∃ws'. redT_updW t ws wa ws'"
by(cases wa)(auto simp add: redT_updW.simps)
lemma redT_updWs_total: "∃ws'. redT_updWs t ws was ws'"
proof(induct was rule: rev_induct)
case Nil thus ?case by(auto simp add: redT_updWs_def)
next
case (snoc wa was)
then obtain ws' where "redT_updWs t ws was ws'" ..
also from redT_updW_total[of t ws' wa]
obtain ws'' where "redT_updW t ws' wa ws''" ..
ultimately show ?case unfolding redT_updWs_def by(auto intro: rtrancl3p_step)
qed
lemma redT_updWs_trans: "⟦ redT_updWs t ws was ws'; redT_updWs t ws' was' ws'' ⟧ ⟹ redT_updWs t ws (was @ was') ws''"
unfolding redT_updWs_def by(rule rtrancl3p_trans)
lemma redT_updW_None_implies_None:
"⟦ redT_updW t' ws wa ws'; ws t = None; t ≠ t' ⟧ ⟹ ws' t = None"
by(auto simp add: redT_updW.simps)
lemma redT_updWs_None_implies_None:
assumes "redT_updWs t' ws was ws'"
and "t ≠ t'" and "ws t = None"
shows "ws' t = None"
using ‹redT_updWs t' ws was ws'› ‹ws t = None› unfolding redT_updWs_def
by induct(auto intro: redT_updW_None_implies_None[OF _ _ ‹t ≠ t'›])
lemma redT_updW_PostWS_imp_PostWS:
"⟦ redT_updW t ws wa ws'; ws t'' = ⌊PostWS w⌋; t'' ≠ t ⟧ ⟹ ws' t'' = ⌊PostWS w⌋"
by(auto simp add: redT_updW.simps)
lemma redT_updWs_PostWS_imp_PostWS:
"⟦ redT_updWs t ws was ws'; t'' ≠ t; ws t'' = ⌊PostWS w⌋ ⟧ ⟹ ws' t'' = ⌊PostWS w⌋"
unfolding redT_updWs_def
by(induct rule: rtrancl3p.induct)(auto dest: redT_updW_PostWS_imp_PostWS)
lemma redT_updW_Some_otherD:
"⟦ redT_updW t' ws wa ws'; ws' t = ⌊w⌋; t ≠ t' ⟧
⟹ (case w of InWS w' ⇒ ws t = ⌊InWS w'⌋ | _ ⇒ ws t = ⌊w⌋ ∨ (∃w'. ws t = ⌊InWS w'⌋))"
by(auto simp add: redT_updW.simps split: if_split_asm wait_set_status.split)
lemma redT_updWs_Some_otherD:
"⟦ redT_updWs t' ws was ws'; ws' t = ⌊w⌋; t ≠ t' ⟧
⟹ (case w of InWS w' ⇒ ws t = ⌊InWS w'⌋ | _ ⇒ ws t = ⌊w⌋ ∨ (∃w'. ws t = ⌊InWS w'⌋))"
unfolding redT_updWs_def
apply(induct arbitrary: w rule: rtrancl3p.induct)
apply(fastforce split: wait_set_status.splits dest: redT_updW_Some_otherD)+
done
lemma redT_updW_None_SomeD:
"⟦ redT_updW t ws wa ws'; ws' t' = ⌊w⌋; ws t' = None ⟧ ⟹ t = t' ∧ (∃w'. w = InWS w' ∧ wa = Suspend w')"
by(auto simp add: redT_updW.simps split: if_split_asm)
lemma redT_updWs_None_SomeD:
"⟦ redT_updWs t ws was ws'; ws' t' = ⌊w⌋; ws t' = None ⟧ ⟹ t = t' ∧ (∃w'. Suspend w' ∈ set was)"
unfolding redT_updWs_def
proof(induct arbitrary: w rule: rtrancl3p.induct)
case (rtrancl3p_refl ws) thus ?case by simp
next
case (rtrancl3p_step ws was ws' wa ws'')
show ?case
proof(cases "ws' t'")
case None
from redT_updW_None_SomeD[OF ‹redT_updW t ws' wa ws''›, OF ‹ws'' t' = ⌊w⌋› this]
show ?thesis by auto
next
case (Some w')
with ‹ws t' = None› rtrancl3p_step.hyps(2) show ?thesis by auto
qed
qed
lemma redT_updW_neq_Some_SomeD:
"⟦ redT_updW t' ws wa ws'; ws' t = ⌊InWS w⌋; ws t ≠ ⌊InWS w⌋ ⟧ ⟹ t = t' ∧ wa = Suspend w"
by(auto simp add: redT_updW.simps split: if_split_asm)
lemma redT_updWs_neq_Some_SomeD:
"⟦ redT_updWs t ws was ws'; ws' t' = ⌊InWS w⌋; ws t' ≠ ⌊InWS w⌋ ⟧ ⟹ t = t' ∧ Suspend w ∈ set was"
unfolding redT_updWs_def
proof(induct rule: rtrancl3p.induct)
case rtrancl3p_refl thus ?case by simp
next
case (rtrancl3p_step ws was ws' wa ws'')
show ?case
proof(cases "ws' t' = ⌊InWS w⌋")
case True
with ‹ws t' ≠ ⌊InWS w⌋› ‹⟦ws' t' = ⌊InWS w⌋; ws t' ≠ ⌊InWS w⌋⟧ ⟹ t = t' ∧ Suspend w ∈ set was›
show ?thesis by simp
next
case False
with ‹redT_updW t ws' wa ws''› ‹ws'' t' = ⌊InWS w⌋›
have "t' = t ∧ wa = Suspend w" by(rule redT_updW_neq_Some_SomeD)
thus ?thesis by auto
qed
qed
lemma redT_updW_not_Suspend_Some:
"⟦ redT_updW t ws wa ws'; ws' t = ⌊w'⌋; ws t = ⌊w⌋; ⋀w. wa ≠ Suspend w ⟧
⟹ w' = w ∨ (∃w'' w'''. w = InWS w'' ∧ w' = PostWS w''')"
by(auto simp add: redT_updW.simps split: if_split_asm)
lemma redT_updWs_not_Suspend_Some:
"⟦ redT_updWs t ws was ws'; ws' t = ⌊w'⌋; ws t = ⌊w⌋; ⋀w. Suspend w ∉ set was ⟧
⟹ w' = w ∨ (∃w'' w'''. w = InWS w'' ∧ w' = PostWS w''')"
unfolding redT_updWs_def
proof(induct arbitrary: w rule: rtrancl3p_converse_induct)
case refl thus ?case by simp
next
case (step ws wa ws' was ws'')
note ‹ws'' t = ⌊w'⌋›
moreover
have "ws' t ≠ None"
proof
assume "ws' t = None"
with ‹rtrancl3p (redT_updW t) ws' was ws''› ‹ws'' t = ⌊w'⌋›
obtain w' where "Suspend w' ∈ set was" unfolding redT_updWs_def[symmetric]
by(auto dest: redT_updWs_None_SomeD)
with ‹Suspend w' ∉ set (wa # was)› show False by simp
qed
then obtain w'' where "ws' t = ⌊w''⌋" by auto
moreover {
fix w
from ‹Suspend w ∉ set (wa # was)› have "Suspend w ∉ set was" by simp }
ultimately have "w' = w'' ∨ (∃w''' w''''. w'' = InWS w''' ∧ w' = PostWS w'''')" by(rule step.hyps)
moreover { fix w
from ‹Suspend w ∉ set (wa # was)› have "wa ≠ Suspend w" by auto }
note redT_updW_not_Suspend_Some[OF ‹redT_updW t ws wa ws'›, OF ‹ws' t = ⌊w''⌋› ‹ws t = ⌊w⌋› this]
ultimately show ?case by auto
qed
lemma redT_updWs_WokenUp_SuspendD:
"⟦ redT_updWs t ws was ws'; Notified ∈ set was ∨ WokenUp ∈ set was; ws' t = ⌊w⌋ ⟧ ⟹ ∃w. Suspend w ∈ set was"
unfolding redT_updWs_def
by(induct rule: rtrancl3p_converse_induct)(auto dest: redT_updWs_None_SomeD[unfolded redT_updWs_def])
lemma redT_updW_Woken_Up_same_no_Notified_Interrupted:
"⟦ redT_updW t ws wa ws'; ws' t = ⌊PostWS w⌋; ws t = ⌊PostWS w⌋; ⋀w. wa ≠ Suspend w ⟧
⟹ wa ≠ Notified ∧ wa ≠ WokenUp"
by(fastforce)
lemma redT_updWs_Woken_Up_same_no_Notified_Interrupted:
"⟦ redT_updWs t ws was ws'; ws' t = ⌊PostWS w⌋; ws t = ⌊PostWS w⌋; ⋀w. Suspend w ∉ set was ⟧
⟹ Notified ∉ set was ∧ WokenUp ∉ set was"
unfolding redT_updWs_def
proof(induct rule: rtrancl3p_converse_induct)
case refl thus ?case by simp
next
case (step ws wa ws' was ws'')
note Suspend = ‹⋀w. Suspend w ∉ set (wa # was)›
note ‹ws'' t = ⌊PostWS w⌋›
moreover have "ws' t = ⌊PostWS w⌋"
proof(cases "ws' t")
case None
with ‹rtrancl3p (redT_updW t) ws' was ws''› ‹ws'' t = ⌊PostWS w⌋›
obtain w where "Suspend w ∈ set was" unfolding redT_updWs_def[symmetric]
by(auto dest: redT_updWs_None_SomeD)
with Suspend[of w] have False by simp
thus ?thesis ..
next
case (Some w')
thus ?thesis using ‹ws t = ⌊PostWS w⌋› Suspend ‹redT_updW t ws wa ws'›
by(auto simp add: redT_updW.simps split: if_split_asm)
qed
moreover
{ fix w from Suspend[of w] have "Suspend w ∉ set was" by simp }
ultimately have "Notified ∉ set was ∧ WokenUp ∉ set was" by(rule step.hyps)
moreover
{ fix w from Suspend[of w] have "wa ≠ Suspend w" by auto }
with ‹redT_updW t ws wa ws'› ‹ws' t = ⌊PostWS w⌋› ‹ws t = ⌊PostWS w⌋›
have "wa ≠ Notified ∧ wa ≠ WokenUp" by(rule redT_updW_Woken_Up_same_no_Notified_Interrupted)
ultimately show ?case by auto
qed
text ‹Preconditions for wait set actions›
definition wset_actions_ok :: "('w,'t) wait_sets ⇒ 't ⇒ ('t,'w) wait_set_action list ⇒ bool"
where
"wset_actions_ok ws t was ⟷
(if Notified ∈ set was then ws t = ⌊PostWS WSNotified⌋
else if WokenUp ∈ set was then ws t = ⌊PostWS WSWokenUp⌋
else ws t = None)"
lemma wset_actions_ok_Nil [simp]:
"wset_actions_ok ws t [] ⟷ ws t = None"
by(simp add: wset_actions_ok_def)
definition waiting :: "'w wait_set_status option ⇒ bool"
where "waiting w ⟷ (∃w'. w = ⌊InWS w'⌋)"
lemma not_waiting_iff:
"¬ waiting w ⟷ w = None ∨ (∃w'. w = ⌊PostWS w'⌋)"
apply(cases "w")
apply(case_tac [2] a)
apply(auto simp add: waiting_def)
done
lemma waiting_code [code]:
"waiting None = False"
"⋀w. waiting ⌊PostWS w⌋ = False"
"⋀w. waiting ⌊InWS w⌋ = True"
by(simp_all add: waiting_def)
end
Theory FWCondAction
section ‹Semantics of the thread actions for purely conditional purpose such as Join›
theory FWCondAction
imports
FWState
begin
locale final_thread =
fixes final :: "'x ⇒ bool"
begin
primrec cond_action_ok :: "('l,'t,'x,'m,'w) state ⇒ 't ⇒ 't conditional_action ⇒ bool" where
"⋀ln. cond_action_ok s t (Join T) =
(case thr s T of None ⇒ True | ⌊(x, ln)⌋ ⇒ t ≠ T ∧ final x ∧ ln = no_wait_locks ∧ wset s T = None)"
| "cond_action_ok s t Yield = True"
primrec cond_action_oks :: "('l,'t,'x,'m,'w) state ⇒ 't ⇒ 't conditional_action list ⇒ bool" where
"cond_action_oks s t [] = True"
| "cond_action_oks s t (ct#cts) = (cond_action_ok s t ct ∧ cond_action_oks s t cts)"
lemma cond_action_oks_append [simp]:
"cond_action_oks s t (cts @ cts') ⟷ cond_action_oks s t cts ∧ cond_action_oks s t cts'"
by(induct cts, auto)
lemma cond_action_oks_conv_set:
"cond_action_oks s t cts ⟷ (∀ct ∈ set cts. cond_action_ok s t ct)"
by(induct cts) simp_all
lemma cond_action_ok_Join:
"⋀ln. ⟦ cond_action_ok s t (Join T); thr s T = ⌊(x, ln)⌋ ⟧ ⟹ final x ∧ ln = no_wait_locks ∧ wset s T = None"
by(auto)
lemma cond_action_oks_Join:
"⋀ln. ⟦ cond_action_oks s t cas; Join T ∈ set cas; thr s T = ⌊(x, ln)⌋ ⟧
⟹ final x ∧ ln = no_wait_locks ∧ wset s T = None ∧ t ≠ T"
by(induct cas)(auto)
lemma cond_action_oks_upd:
assumes tst: "thr s t = ⌊xln⌋"
shows "cond_action_oks (locks s, (thr s(t ↦ xln'), shr s), wset s, interrupts s) t cas = cond_action_oks s t cas"
proof(induct cas)
case Nil thus ?case by simp
next
case (Cons ca cas)
from tst have eq: "cond_action_ok (locks s, (thr s(t ↦ xln'), shr s), wset s, interrupts s) t ca = cond_action_ok s t ca"
by(cases ca) auto
with Cons show ?case by(auto simp del: fun_upd_apply)
qed
lemma cond_action_ok_shr_change:
"cond_action_ok (ls, (ts, m), ws, is) t ct ⟹ cond_action_ok (ls, (ts, m'), ws, is) t ct"
by(cases ct) auto
lemma cond_action_oks_shr_change:
"cond_action_oks (ls, (ts, m), ws, is) t cts ⟹ cond_action_oks (ls, (ts, m'), ws, is) t cts"
by(auto simp add: cond_action_oks_conv_set intro: cond_action_ok_shr_change)
primrec cond_action_ok' :: "('l,'t,'x,'m,'w) state ⇒ 't ⇒ 't conditional_action ⇒ bool"
where
"cond_action_ok' _ _ (Join t) = True"
| "cond_action_ok' _ _ Yield = True"
primrec cond_action_oks' :: "('l,'t,'x,'m,'w) state ⇒ 't ⇒ 't conditional_action list ⇒ bool" where
"cond_action_oks' s t [] = True"
| "cond_action_oks' s t (ct#cts) = (cond_action_ok' s t ct ∧ cond_action_oks' s t cts)"
lemma cond_action_oks'_append [simp]:
"cond_action_oks' s t (cts @ cts') ⟷ cond_action_oks' s t cts ∧ cond_action_oks' s t cts'"
by(induct cts, auto)
lemma cond_action_oks'_subset_Join:
"set cts ⊆ insert Yield (range Join) ⟹ cond_action_oks' s t cts"
apply(induct cts)
apply(auto)
done
end
definition collect_cond_actions :: "'t conditional_action list ⇒ 't set" where
"collect_cond_actions cts = {t. Join t ∈ set cts}"
declare collect_cond_actions_def [simp]
lemma cond_action_ok_final_change:
"⟦ final_thread.cond_action_ok final1 s1 t ca;
⋀t. thr s1 t = None ⟷ thr s2 t = None;
⋀t x1. ⟦ thr s1 t = ⌊(x1, no_wait_locks)⌋; final1 x1; wset s1 t = None ⟧
⟹ ∃x2. thr s2 t = ⌊(x2, no_wait_locks)⌋ ∧ final2 x2 ∧ ln2 = no_wait_locks ∧ wset s2 t = None ⟧
⟹ final_thread.cond_action_ok final2 s2 t ca"
apply(cases ca)
apply(fastforce simp add: final_thread.cond_action_ok.simps)+
done
lemma cond_action_oks_final_change:
assumes major: "final_thread.cond_action_oks final1 s1 t cas"
and minor: "⋀t. thr s1 t = None ⟷ thr s2 t = None"
"⋀t x1. ⟦ thr s1 t = ⌊(x1, no_wait_locks)⌋; final1 x1; wset s1 t = None ⟧
⟹ ∃x2. thr s2 t = ⌊(x2, no_wait_locks)⌋ ∧ final2 x2 ∧ ln2 = no_wait_locks ∧ wset s2 t = None"
shows "final_thread.cond_action_oks final2 s2 t cas"
using major
by(induct cas)(auto simp add: final_thread.cond_action_oks.simps intro: cond_action_ok_final_change[OF _ minor])
end
Theory FWLockingThread
section ‹Semantics of the thread action ReleaseAcquire for the thread state›
theory FWLockingThread
imports
FWLocking
begin
fun upd_threadR :: "nat ⇒ 't lock ⇒ 't ⇒ lock_action ⇒ nat"
where
"upd_threadR n l t ReleaseAcquire = n + has_locks l t"
| "upd_threadR n l t _ = n"
primrec upd_threadRs :: "nat ⇒ 't lock ⇒ 't ⇒ lock_action list ⇒ nat"
where
"upd_threadRs n l t [] = n"
| "upd_threadRs n l t (la # las) = upd_threadRs (upd_threadR n l t la) (upd_lock l t la) t las"
lemma upd_threadRs_append [simp]:
"upd_threadRs n l t (las @ las') = upd_threadRs (upd_threadRs n l t las) (upd_locks l t las) t las'"
by(induct las arbitrary: n l, auto)
definition redT_updLns :: "('l,'t) locks ⇒ 't ⇒ ('l ⇒f nat) ⇒ 'l lock_actions ⇒ ('l ⇒f nat)"
where "⋀ln. redT_updLns ls t ln las = (λ(l, n, la). upd_threadRs n l t la) ∘$ ($ls, ($ln, las$)$)"
lemma redT_updLns_iff [simp]:
"⋀ln. redT_updLns ls t ln las $ l = upd_threadRs (ln $ l) (ls $ l) t (las $ l)"
by(simp add: redT_updLns_def)
lemma upd_threadRs_comp_empty [simp]: "(λ(l, n, las). upd_threadRs n l t las) ∘$ ($ls, ($lns, K$ []$)$) = lns"
by(auto intro!: finfun_ext)
lemma redT_updLs_empty [simp]: "redT_updLs ls t (K$ []) = ls"
by(simp add: redT_updLs_def)
end
Theory FWInterrupt
section ‹Semantics of the thread actions for interruption›
theory FWInterrupt
imports
FWState
begin
primrec redT_updI :: "'t interrupts ⇒ 't interrupt_action ⇒ 't interrupts"
where
"redT_updI is (Interrupt t) = insert t is"
| "redT_updI is (ClearInterrupt t) = is - {t}"
| "redT_updI is (IsInterrupted t b) = is"
fun redT_updIs :: "'t interrupts ⇒ 't interrupt_action list ⇒ 't interrupts"
where
"redT_updIs is [] = is"
| "redT_updIs is (ia # ias) = redT_updIs (redT_updI is ia) ias"
primrec interrupt_action_ok :: "'t interrupts ⇒ 't interrupt_action ⇒ bool"
where
"interrupt_action_ok is (Interrupt t) = True"
| "interrupt_action_ok is (ClearInterrupt t) = True"
| "interrupt_action_ok is (IsInterrupted t b) = (b = (t ∈ is))"
fun interrupt_actions_ok :: "'t interrupts ⇒ 't interrupt_action list ⇒ bool"
where
"interrupt_actions_ok is [] = True"
| "interrupt_actions_ok is (ia # ias) ⟷ interrupt_action_ok is ia ∧ interrupt_actions_ok (redT_updI is ia) ias"
primrec interrupt_action_ok' :: "'t interrupts ⇒ 't interrupt_action ⇒ bool"
where
"interrupt_action_ok' is (Interrupt t) = True"
| "interrupt_action_ok' is (ClearInterrupt t) = True"
| "interrupt_action_ok' is (IsInterrupted t b) = (b ∨ t ∉ is)"
fun interrupt_actions_ok' :: "'t interrupts ⇒ 't interrupt_action list ⇒ bool"
where
"interrupt_actions_ok' is [] = True"
| "interrupt_actions_ok' is (ia # ias) ⟷ interrupt_action_ok' is ia ∧ interrupt_actions_ok' (redT_updI is ia) ias"
fun collect_interrupt :: "'t interrupt_action ⇒ 't set ⇒ 't set"
where
"collect_interrupt (IsInterrupted t True) Ts = insert t Ts"
| "collect_interrupt (Interrupt t) Ts = Ts - {t}"
| "collect_interrupt _ Ts = Ts"
definition collect_interrupts :: "'t interrupt_action list ⇒ 't set"
where "collect_interrupts ias = foldr collect_interrupt ias {}"
lemma collect_interrupts_interrupted:
"⟦ interrupt_actions_ok is ias; t' ∈ collect_interrupts ias ⟧ ⟹ t' ∈ is"
unfolding collect_interrupts_def
proof(induct ias arbitrary: "is")
case Nil thus ?case by simp
next
case (Cons ia ias) thus ?case
by(cases "(ia, foldr collect_interrupt ias {})" rule: collect_interrupt.cases) auto
qed
lemma interrupt_actions_ok_append [simp]:
"interrupt_actions_ok is (ias @ ias') ⟷ interrupt_actions_ok is ias ∧ interrupt_actions_ok (redT_updIs is ias) ias'"
by(induct ias arbitrary: "is") auto
lemma collect_interrupt_subset: "Ts ⊆ Ts' ⟹ collect_interrupt ia Ts ⊆ collect_interrupt ia Ts'"
by(cases "(ia, Ts)" rule: collect_interrupt.cases) auto
lemma foldr_collect_interrupt_subset:
"Ts ⊆ Ts' ⟹ foldr collect_interrupt ias Ts ⊆ foldr collect_interrupt ias Ts'"
by(induct ias)(simp_all add: collect_interrupt_subset)
lemma interrupt_actions_ok_all_nthI:
assumes "⋀n. n < length ias ⟹ interrupt_action_ok (redT_updIs is (take n ias)) (ias ! n)"
shows "interrupt_actions_ok is ias"
using assms
proof(induct ias arbitrary: "is")
case Nil thus ?case by simp
next
case (Cons ia ias)
from Cons.prems[of 0] have "interrupt_action_ok is ia" by simp
moreover
{ fix n
assume "n < length ias"
hence "interrupt_action_ok (redT_updIs (redT_updI is ia) (take n ias)) (ias ! n)"
using Cons.prems[of "Suc n"] by simp }
hence "interrupt_actions_ok (redT_updI is ia) ias" by(rule Cons.hyps)
ultimately show ?case by simp
qed
lemma interrupt_actions_ok_nthD:
assumes "interrupt_actions_ok is ias"
and "n < length ias"
shows "interrupt_action_ok (redT_updIs is (take n ias)) (ias ! n)"
using assms
by(induct n arbitrary: "is" ias)(case_tac [!] ias, auto)
lemma interrupt_actions_ok'_all_nthI:
assumes "⋀n. n < length ias ⟹ interrupt_action_ok' (redT_updIs is (take n ias)) (ias ! n)"
shows "interrupt_actions_ok' is ias"
using assms
proof(induct ias arbitrary: "is")
case Nil thus ?case by simp
next
case (Cons ia ias)
from Cons.prems[of 0] have "interrupt_action_ok' is ia" by simp
moreover
{ fix n
assume "n < length ias"
hence "interrupt_action_ok' (redT_updIs (redT_updI is ia) (take n ias)) (ias ! n)"
using Cons.prems[of "Suc n"] by simp }
hence "interrupt_actions_ok' (redT_updI is ia) ias" by(rule Cons.hyps)
ultimately show ?case by simp
qed
lemma interrupt_actions_ok'_nthD:
assumes "interrupt_actions_ok' is ias"
and "n < length ias"
shows "interrupt_action_ok' (redT_updIs is (take n ias)) (ias ! n)"
using assms
by(induct n arbitrary: "is" ias)(case_tac [!] ias, auto)
lemma interrupt_action_ok_imp_interrupt_action_ok' [simp]:
"interrupt_action_ok is ia ⟹ interrupt_action_ok' is ia"
by(cases ia) simp_all
lemma interrupt_actions_ok_imp_interrupt_actions_ok' [simp]:
"interrupt_actions_ok is ias ⟹ interrupt_actions_ok' is ias"
by(induct ias arbitrary: "is")(simp_all)
lemma collect_interruptsE:
assumes "t' ∈ collect_interrupts ias'"
obtains n' where "n' < length ias'" "ias' ! n' = IsInterrupted t' True"
and "Interrupt t' ∉ set (take n' ias')"
proof(atomize_elim)
from assms show "∃n'<length ias'. ias' ! n' = IsInterrupted t' True ∧ Interrupt t' ∉ set (take n' ias')"
unfolding collect_interrupts_def
proof(induct ias' arbitrary: t')
case Nil thus ?case by simp
next
case (Cons ia ias) thus ?case
by(cases "(ia, foldr collect_interrupt ias {})" rule: collect_interrupt.cases) fastforce+
qed
qed
lemma collect_interrupts_prefix:
"collect_interrupts ias ⊆ collect_interrupts (ias @ ias')"
by (metis Un_empty collect_interrupts_def foldr_append foldr_collect_interrupt_subset inf_sup_ord(1) inf_sup_ord(2) subset_Un_eq)
lemma redT_updI_insert_Interrupt:
"⟦ t ∈ redT_updI is ia; t ∉ is ⟧ ⟹ ia = Interrupt t"
by(cases ia) simp_all
lemma redT_updIs_insert_Interrupt:
"⟦ t ∈ redT_updIs is ias; t ∉ is ⟧ ⟹ Interrupt t ∈ set ias"
proof(induct ias arbitrary: "is")
case Nil thus ?case by simp
next
case (Cons ia ias) thus ?case
by(cases "t ∈ redT_updI is ia")(auto dest: redT_updI_insert_Interrupt)
qed
lemma interrupt_actions_ok_takeI:
"interrupt_actions_ok is ias ⟹ interrupt_actions_ok is (take n ias)"
by(subst (asm) append_take_drop_id[symmetric, where n=n])(simp del: append_take_drop_id)
lemma interrupt_actions_ok'_collect_interrupts_imp_interrupt_actions_ok:
assumes int: "interrupt_actions_ok' is ias"
and ci: "collect_interrupts ias ⊆ is"
and int': "interrupt_actions_ok is' ias"
shows "interrupt_actions_ok is ias"
proof(rule interrupt_actions_ok_all_nthI)
fix n
assume n: "n < length ias"
show "interrupt_action_ok (redT_updIs is (take n ias)) (ias ! n)"
proof(cases "∃t. ias ! n = IsInterrupted t True")
case False
with interrupt_actions_ok'_nthD[OF int n] show ?thesis by(cases "ias ! n") simp_all
next
case True
then obtain t where ia: "ias ! n = IsInterrupted t True" ..
from int' n have "interrupt_action_ok (redT_updIs is' (take n ias)) (ias ! n)" by(rule interrupt_actions_ok_nthD)
with ia have "t ∈ redT_updIs is' (take n ias)" by simp
moreover have "ias = take (Suc n) ias @ drop (Suc n) ias" by simp
with ci have "collect_interrupts (take (Suc n) ias) ⊆ is"
by (metis collect_interrupts_prefix subset_trans)
ultimately have "t ∈ redT_updIs is (take n ias)" using n ia int int'
proof(induct n arbitrary: "is" is' ias)
case 0 thus ?case by(clarsimp simp add: neq_Nil_conv collect_interrupts_def)
next
case (Suc n)
from ‹Suc n < length ias› obtain ia ias'
where ias [simp]: "ias = ia # ias'" by(cases ias) auto
from ‹interrupt_actions_ok is' ias›
have ia_ok: "interrupt_action_ok is' ia" by simp
from ‹t ∈ redT_updIs is' (take (Suc n) ias)›
have "t ∈ redT_updIs (redT_updI is' ia) (take n ias')" by simp
moreover from ‹collect_interrupts (take (Suc (Suc n)) ias) ⊆ is› ia_ok
have "collect_interrupts (take (Suc n) ias') ⊆ redT_updI is ia"
proof(cases "(ia, is)" rule: collect_interrupt.cases)
case ("3_2" t' Ts)
hence [simp]: "ia = ClearInterrupt t'" "Ts = is" by simp_all
have "t' ∉ collect_interrupts (take (Suc n) ias')"
proof
assume "t' ∈ collect_interrupts (take (Suc n) ias')"
then obtain n' where "n' < length (take (Suc n) ias')" "take (Suc n) ias' ! n' = IsInterrupted t' True"
"Interrupt t' ∉ set (take n' (take (Suc n) ias'))" by(rule collect_interruptsE)
hence "n' ≤ n" "ias' ! n' = IsInterrupted t' True" "Interrupt t' ∉ set (take n' ias')"
using ‹Suc n < length ias› by(simp_all add: min_def split: if_split_asm)
hence "Suc n' < length ias" using ‹Suc n < length ias› by(simp add: min_def)
with ‹interrupt_actions_ok is' ias›
have "interrupt_action_ok (redT_updIs is' (take (Suc n') ias)) (ias ! Suc n')"
by(rule interrupt_actions_ok_nthD)
with ‹Suc n < length ias› ‹ias' ! n' = IsInterrupted t' True›
have "t' ∈ redT_updIs (is' - {t'}) (take n' ias')" by simp
hence "Interrupt t' ∈ set (take n' ias')"
by(rule redT_updIs_insert_Interrupt) simp
with ‹Interrupt t' ∉ set (take n' ias')› show False by contradiction
qed
thus ?thesis using ‹collect_interrupts (take (Suc (Suc n)) ias) ⊆ is›
by(auto simp add: collect_interrupts_def)
qed(auto simp add: collect_interrupts_def)
moreover from ‹Suc n < length ias› have "n < length ias'" by simp
moreover from ‹ias ! Suc n = IsInterrupted t True› have "ias' ! n = IsInterrupted t True" by simp
moreover from ‹interrupt_actions_ok' is ias› have "interrupt_actions_ok' (redT_updI is ia) ias'"
unfolding ias by simp
moreover from ‹interrupt_actions_ok is' ias› have "interrupt_actions_ok (redT_updI is' ia) ias'" by simp
ultimately have "t ∈ redT_updIs (redT_updI is ia) (take n ias')" by(rule Suc)
thus ?case by simp
qed
thus ?thesis unfolding ia by simp
qed
qed
end
Theory FWSemantics
section ‹The multithreaded semantics›
theory FWSemantics
imports
FWWellform
FWLockingThread
FWCondAction
FWInterrupt
begin
inductive redT_upd :: "('l,'t,'x,'m,'w) state ⇒ 't ⇒ ('l,'t,'x,'m,'w,'o) thread_action ⇒ 'x ⇒ 'm ⇒ ('l,'t,'x,'m,'w) state ⇒ bool"
for s t ta x' m'
where
"redT_updWs t (wset s) ⦃ta⦄⇘w⇙ ws'
⟹ redT_upd s t ta x' m' (redT_updLs (locks s) t ⦃ta⦄⇘l⇙, ((redT_updTs (thr s) ⦃ta⦄⇘t⇙)(t ↦ (x', redT_updLns (locks s) t (snd (the (thr s t))) ⦃ta⦄⇘l⇙)), m'), ws', redT_updIs (interrupts s) ⦃ta⦄⇘i⇙)"
inductive_simps redT_upd_simps [simp]:
"redT_upd s t ta x' m' s'"
definition redT_acq :: "('l,'t,'x,'m,'w) state ⇒ 't ⇒ ('l ⇒f nat) ⇒ ('l,'t,'x,'m,'w) state"
where
"⋀ln. redT_acq s t ln = (acquire_all (locks s) t ln, ((thr s)(t ↦ (fst (the (thr s t)), no_wait_locks)), shr s), wset s, interrupts s)"
context final_thread begin
inductive actions_ok :: "('l,'t,'x,'m,'w) state ⇒ 't ⇒ ('l,'t,'x','m,'w,'o) thread_action ⇒ bool"
for s :: "('l,'t,'x,'m,'w) state" and t :: 't and ta :: "('l,'t,'x','m,'w,'o) thread_action"
where
"⟦ lock_ok_las (locks s) t ⦃ta⦄⇘l⇙; thread_oks (thr s) ⦃ta⦄⇘t⇙; cond_action_oks s t ⦃ta⦄⇘c⇙;
wset_actions_ok (wset s) t ⦃ta⦄⇘w⇙; interrupt_actions_ok (interrupts s) ⦃ta⦄⇘i⇙ ⟧
⟹ actions_ok s t ta"
declare actions_ok.intros [intro!]
declare actions_ok.cases [elim!]
lemma actions_ok_iff [simp]:
"actions_ok s t ta ⟷
lock_ok_las (locks s) t ⦃ta⦄⇘l⇙ ∧ thread_oks (thr s) ⦃ta⦄⇘t⇙ ∧ cond_action_oks s t ⦃ta⦄⇘c⇙ ∧
wset_actions_ok (wset s) t ⦃ta⦄⇘w⇙ ∧ interrupt_actions_ok (interrupts s) ⦃ta⦄⇘i⇙"
by(auto)
lemma actions_ok_thread_oksD:
"actions_ok s t ta ⟹ thread_oks (thr s) ⦃ta⦄⇘t⇙"
by(erule actions_ok.cases)
inductive actions_ok' :: "('l,'t,'x,'m,'w) state ⇒ 't ⇒ ('l,'t,'x','m,'w,'o) thread_action ⇒ bool" where
"⟦ lock_ok_las' (locks s) t ⦃ta⦄⇘l⇙; thread_oks (thr s) ⦃ta⦄⇘t⇙; cond_action_oks' s t ⦃ta⦄⇘c⇙;
wset_actions_ok (wset s) t ⦃ta⦄⇘w⇙; interrupt_actions_ok' (interrupts s) ⦃ta⦄⇘i⇙ ⟧
⟹ actions_ok' s t ta"
declare actions_ok'.intros [intro!]
declare actions_ok'.cases [elim!]
lemma actions_ok'_iff:
"actions_ok' s t ta ⟷
lock_ok_las' (locks s) t ⦃ta⦄⇘l⇙ ∧ thread_oks (thr s) ⦃ta⦄⇘t⇙ ∧ cond_action_oks' s t ⦃ta⦄⇘c⇙ ∧
wset_actions_ok (wset s) t ⦃ta⦄⇘w⇙ ∧ interrupt_actions_ok' (interrupts s) ⦃ta⦄⇘i⇙"
by auto
lemma actions_ok'_ta_upd_obs:
"actions_ok' s t (ta_update_obs ta obs) ⟷ actions_ok' s t ta"
by(auto simp add: actions_ok'_iff lock_ok_las'_def ta_upd_simps wset_actions_ok_def)
lemma actions_ok'_empty: "actions_ok' s t ε ⟷ wset s t = None"
by(simp add: actions_ok'_iff lock_ok_las'_def)
lemma actions_ok'_convert_extTA:
"actions_ok' s t (convert_extTA f ta) = actions_ok' s t ta"
by(simp add: actions_ok'_iff)
inductive actions_subset :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ ('l,'t,'x','m,'w,'o) thread_action ⇒ bool"
where
"⟦ collect_locks' ⦃ta'⦄⇘l⇙ ⊆ collect_locks ⦃ta⦄⇘l⇙;
collect_cond_actions ⦃ta'⦄⇘c⇙ ⊆ collect_cond_actions ⦃ta⦄⇘c⇙;
collect_interrupts ⦃ta'⦄⇘i⇙ ⊆ collect_interrupts ⦃ta⦄⇘i⇙ ⟧
⟹ actions_subset ta' ta"
declare actions_subset.intros [intro!]
declare actions_subset.cases [elim!]
lemma actions_subset_iff:
"actions_subset ta' ta ⟷
collect_locks' ⦃ta'⦄⇘l⇙ ⊆ collect_locks ⦃ta⦄⇘l⇙ ∧
collect_cond_actions ⦃ta'⦄⇘c⇙ ⊆ collect_cond_actions ⦃ta⦄⇘c⇙ ∧
collect_interrupts ⦃ta'⦄⇘i⇙ ⊆ collect_interrupts ⦃ta⦄⇘i⇙"
by auto
lemma actions_subset_refl [intro]:
"actions_subset ta ta"
by(auto intro: actions_subset.intros collect_locks'_subset_collect_locks del: subsetI)
definition final_thread :: "('l,'t,'x,'m,'w) state ⇒ 't ⇒ bool" where
"⋀ln. final_thread s t ≡ (case thr s t of None ⇒ False | ⌊(x, ln)⌋ ⇒ final x ∧ ln = no_wait_locks ∧ wset s t = None)"
definition final_threads :: "('l,'t,'x,'m,'w) state ⇒ 't set"
where "final_threads s ≡ {t. final_thread s t}"
lemma [iff]: "t ∈ final_threads s = final_thread s t"
by (simp add: final_threads_def)
lemma [pred_set_conv]: "final_thread s = (λt. t ∈ final_threads s)"
by simp
definition mfinal :: "('l,'t,'x,'m,'w) state ⇒ bool"
where "mfinal s ⟷ (∀t x ln. thr s t = ⌊(x, ln)⌋ ⟶ final x ∧ ln = no_wait_locks ∧ wset s t = None)"
lemma final_threadI:
"⟦ thr s t = ⌊(x, no_wait_locks)⌋; final x; wset s t = None ⟧ ⟹ final_thread s t"
by(simp add: final_thread_def)
lemma final_threadE:
assumes "final_thread s t"
obtains x where "thr s t = ⌊(x, no_wait_locks)⌋" "final x" "wset s t = None"
using assms by(auto simp add: final_thread_def)
lemma mfinalI:
"(⋀t x ln. thr s t = ⌊(x, ln)⌋ ⟹ final x ∧ ln = no_wait_locks ∧ wset s t = None) ⟹ mfinal s"
unfolding mfinal_def by blast
lemma mfinalD:
fixes ln
assumes "mfinal s" "thr s t = ⌊(x, ln)⌋"
shows "final x" "ln = no_wait_locks" "wset s t = None"
using assms unfolding mfinal_def by blast+
lemma mfinalE:
fixes ln
assumes "mfinal s" "thr s t = ⌊(x, ln)⌋"
obtains "final x" "ln = no_wait_locks" "wset s t = None"
using mfinalD[OF assms] by(rule that)
lemma mfinal_def2: "mfinal s ⟷ dom (thr s) ⊆ final_threads s"
by(fastforce elim: mfinalE final_threadE intro: mfinalI final_threadI)
end
locale multithreaded_base = final_thread +
constrains final :: "'x ⇒ bool"
fixes r :: "('l,'t,'x,'m,'w,'o) semantics" ("_ ⊢ _ -_→ _" [50,0,0,50] 80)
and convert_RA :: "'l released_locks ⇒ 'o list"
begin
abbreviation
r_syntax :: "'t ⇒ 'x ⇒ 'm ⇒ ('l,'t,'x,'m,'w,'o) thread_action ⇒ 'x ⇒ 'm ⇒ bool"
("_ ⊢ ⟨_, _⟩ -_→ ⟨_, _⟩" [50,0,0,0,0,0] 80)
where
"t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩ ≡ t ⊢ (x, m) -ta→ (x', m')"
inductive
redT :: "('l,'t,'x,'m,'w) state ⇒ 't × ('l,'t,'x,'m,'w,'o) thread_action ⇒ ('l,'t,'x,'m,'w) state ⇒ bool" and
redT_syntax1 :: "('l,'t,'x,'m,'w) state ⇒ 't ⇒ ('l,'t,'x,'m,'w,'o) thread_action ⇒ ('l,'t,'x,'m,'w) state ⇒ bool" ("_ -_▹_→ _" [50,0,0,50] 80)
where
"s -t▹ta→ s' ≡ redT s (t, ta) s'"
| redT_normal:
"⟦ t ⊢ ⟨x, shr s⟩ -ta→ ⟨x', m'⟩;
thr s t = ⌊(x, no_wait_locks)⌋;
actions_ok s t ta;
redT_upd s t ta x' m' s' ⟧
⟹ s -t▹ta→ s'"
| redT_acquire:
"⋀ln. ⟦ thr s t = ⌊(x, ln)⌋; ¬ waiting (wset s t);
may_acquire_all (locks s) t ln; ln $ n > 0;
s' = (acquire_all (locks s) t ln, (thr s(t ↦ (x, no_wait_locks)), shr s), wset s, interrupts s) ⟧
⟹ s -t▹((K$ []), [], [], [], [], convert_RA ln)→ s'"
abbreviation
redT_syntax2 :: "('l,'t) locks ⇒ ('l,'t,'x) thread_info × 'm ⇒ ('w,'t) wait_sets ⇒ 't interrupts
⇒ 't ⇒ ('l,'t,'x,'m,'w,'o) thread_action
⇒ ('l,'t) locks ⇒ ('l,'t,'x) thread_info × 'm ⇒ ('w,'t) wait_sets ⇒ 't interrupts ⇒ bool"
("⟨_, _, _, _⟩ -_▹_→ ⟨_, _, _, _⟩" [0,0,0,0,0,0,0,0,0] 80)
where
"⟨ls, tsm, ws, is⟩ -t▹ta→ ⟨ls', tsm', ws', is'⟩ ≡ (ls, tsm, ws, is) -t▹ta→ (ls', tsm', ws', is')"
lemma redT_elims [consumes 1, case_names normal acquire]:
assumes red: "s -t▹ta→ s'"
and normal: "⋀x x' m' ws'.
⟦ t ⊢ ⟨x, shr s⟩ -ta→ ⟨x', m'⟩;
thr s t = ⌊(x, no_wait_locks)⌋;
lock_ok_las (locks s) t ⦃ta⦄⇘l⇙;
thread_oks (thr s) ⦃ta⦄⇘t⇙;
cond_action_oks s t ⦃ta⦄⇘c⇙;
wset_actions_ok (wset s) t ⦃ta⦄⇘w⇙;
interrupt_actions_ok (interrupts s) ⦃ta⦄⇘i⇙;
redT_updWs t (wset s) ⦃ta⦄⇘w⇙ ws';
s' = (redT_updLs (locks s) t ⦃ta⦄⇘l⇙, (redT_updTs (thr s) ⦃ta⦄⇘t⇙(t ↦ (x', redT_updLns (locks s) t no_wait_locks ⦃ta⦄⇘l⇙)), m'), ws', redT_updIs (interrupts s) ⦃ta⦄⇘i⇙) ⟧
⟹ thesis"
and acquire: "⋀x ln n.
⟦ thr s t = ⌊(x, ln)⌋;
ta = (K$ [], [], [], [], [], convert_RA ln);
¬ waiting (wset s t);
may_acquire_all (locks s) t ln; 0 < ln $ n;
s' = (acquire_all (locks s) t ln, (thr s(t ↦ (x, no_wait_locks)), shr s), wset s, interrupts s) ⟧
⟹ thesis"
shows thesis
using red
proof cases
case redT_normal
thus ?thesis using normal by(cases s')(auto)
next
case redT_acquire
thus ?thesis by-(rule acquire, fastforce+)
qed
definition
RedT :: "('l,'t,'x,'m,'w) state ⇒ ('t × ('l,'t,'x,'m,'w,'o) thread_action) list ⇒ ('l,'t,'x,'m,'w) state ⇒ bool"
("_ -▹_→* _" [50,0,50] 80)
where
"RedT ≡ rtrancl3p redT"
lemma RedTI:
"rtrancl3p redT s ttas s' ⟹ RedT s ttas s'"
by(simp add: RedT_def)
lemma RedTE:
"⟦ RedT s ttas s'; rtrancl3p redT s ttas s' ⟹ P ⟧ ⟹ P"
by(auto simp add: RedT_def)
lemma RedTD:
"RedT s ttas s' ⟹ rtrancl3p redT s ttas s'"
by(simp add: RedT_def)
lemma RedT_induct [consumes 1, case_names refl step]:
"⟦ s -▹ttas→* s';
⋀s. P s [] s;
⋀s ttas s' t ta s''. ⟦ s -▹ttas→* s'; P s ttas s'; s' -t▹ta→ s'' ⟧ ⟹ P s (ttas @ [(t, ta)]) s''⟧
⟹ P s ttas s'"
unfolding RedT_def
by(erule rtrancl3p.induct) auto
lemma RedT_induct' [consumes 1, case_names refl step]:
"⟦ s -▹ttas→* s';
P s [] s;
⋀ttas s' t ta s''. ⟦ s -▹ttas→* s'; P s ttas s'; s' -t▹ta→ s'' ⟧ ⟹ P s (ttas @ [(t, ta)]) s''⟧
⟹ P s ttas s'"
unfolding RedT_def
apply(erule rtrancl3p_induct', blast)
apply(case_tac b, blast)
done
lemma RedT_lift_preserveD:
assumes Red: "s -▹ttas→* s'"
and P: "P s"
and preserve: "⋀s t tas s'. ⟦ s -t▹tas→ s'; P s ⟧ ⟹ P s'"
shows "P s'"
using Red P
by(induct rule: RedT_induct)(auto intro: preserve)
lemma RedT_refl [intro, simp]:
"s -▹[]→* s"
by(rule RedTI)(rule rtrancl3p_refl)
lemma redT_has_locks_inv:
"⟦ ⟨ls, (ts, m), ws, is⟩ -t▹ta→ ⟨ls', (ts', m'), ws', is'⟩; t ≠ t' ⟧ ⟹
has_locks (ls $ l) t' = has_locks (ls' $ l) t'"
by(auto elim!: redT.cases intro: redT_updLs_has_locks[THEN sym, simplified] may_acquire_all_has_locks_acquire_locks[symmetric])
lemma redT_has_lock_inv:
"⟦ ⟨ls, (ts, m), ws, is⟩ -t▹ta→ ⟨ls', (ts', m'), ws', is'⟩; t ≠ t' ⟧
⟹ has_lock (ls' $ l) t' = has_lock (ls $ l) t'"
by(auto simp add: redT_has_locks_inv)
lemma redT_ts_Some_inv:
"⟦ ⟨ls, (ts, m), ws, is⟩ -t▹ta→ ⟨ls', (ts', m'), ws', is'⟩; t ≠ t'; ts t' = ⌊x⌋ ⟧ ⟹ ts' t' = ⌊x⌋"
by(fastforce elim!: redT.cases simp: redT_updTs_upd[THEN sym] intro: redT_updTs_Some)
lemma redT_thread_not_disappear:
"⟦ s -t▹ta→ s'; thr s' t' = None⟧ ⟹ thr s t' = None"
apply(cases "t ≠ t'")
apply(auto elim!: redT_elims simp add: redT_updTs_upd[THEN sym] intro: redT_updTs_None)
done
lemma RedT_thread_not_disappear:
"⟦ s -▹ttas→* s'; thr s' t' = None⟧ ⟹ thr s t' = None"
apply(erule contrapos_pp[where Q="thr s' t' = None"])
apply(drule (1) RedT_lift_preserveD)
apply(erule_tac Q="thr sa t' = None" in contrapos_nn)
apply(erule redT_thread_not_disappear)
apply(auto)
done
lemma redT_preserves_wset_thread_ok:
"⟦ s -t▹ta→ s'; wset_thread_ok (wset s) (thr s) ⟧ ⟹ wset_thread_ok (wset s') (thr s')"
by(fastforce elim!: redT.cases intro: wset_thread_ok_upd redT_updTs_preserves_wset_thread_ok redT_updWs_preserve_wset_thread_ok)
lemma RedT_preserves_wset_thread_ok:
"⟦ s -▹ttas→* s'; wset_thread_ok (wset s) (thr s) ⟧ ⟹ wset_thread_ok (wset s') (thr s')"
by(erule (1) RedT_lift_preserveD)(erule redT_preserves_wset_thread_ok)
lemma redT_new_thread_ts_Some:
"⟦ s -t▹ta→ s'; NewThread t' x m'' ∈ set ⦃ta⦄⇘t⇙; wset_thread_ok (wset s) (thr s) ⟧
⟹ thr s' t' = ⌊(x, no_wait_locks)⌋"
by(erule redT_elims)(auto dest: thread_oks_new_thread elim: redT_updTs_new_thread_ts)
lemma RedT_new_thread_ts_not_None:
"⟦ s -▹ttas→* s'; NewThread t x m'' ∈ set (concat (map (thr_a ∘ snd) ttas)); wset_thread_ok (wset s) (thr s) ⟧
⟹ thr s' t ≠ None"
proof(induct rule: RedT_induct)
case refl thus ?case by simp
next
case (step S TTAS S' T TA S'')
note Red = ‹S -▹TTAS→* S'›
note IH = ‹⟦ NewThread t x m'' ∈ set (concat (map (thr_a ∘ snd) TTAS)); wset_thread_ok (wset S) (thr S) ⟧ ⟹ thr S' t ≠ None›
note red = ‹S' -T▹TA→ S''›
note ins = ‹NewThread t x m'' ∈ set (concat (map (thr_a ∘ snd) (TTAS @ [(T, TA)])))›
note wto = ‹wset_thread_ok (wset S) (thr S)›
from Red wto have wto': "wset_thread_ok (wset S') (thr S')" by(auto dest: RedT_preserves_wset_thread_ok)
show ?case
proof(cases "NewThread t x m'' ∈ set ⦃TA⦄⇘t⇙")
case True thus ?thesis using red wto'
by(auto dest!: redT_new_thread_ts_Some)
next
case False
hence "NewThread t x m'' ∈ set (concat (map (thr_a ∘ snd) TTAS))" using ins by(auto)
hence "thr S' t ≠ None" using wto by(rule IH)
with red show ?thesis
by -(erule contrapos_nn, auto dest: redT_thread_not_disappear)
qed
qed
lemma redT_preserves_lock_thread_ok:
"⟦ s -t▹ta→ s'; lock_thread_ok (locks s) (thr s) ⟧ ⟹ lock_thread_ok (locks s') (thr s')"
by(auto elim!: redT_elims intro: redT_upds_preserves_lock_thread_ok acquire_all_preserves_lock_thread_ok)
lemma RedT_preserves_lock_thread_ok:
"⟦ s -▹ttas→* s'; lock_thread_ok (locks s) (thr s) ⟧ ⟹ lock_thread_ok (locks s') (thr s')"
by(erule (1) RedT_lift_preserveD)(erule redT_preserves_lock_thread_ok)
lemma redT_ex_new_thread:
assumes "s -t'▹ta→ s'" "wset_thread_ok (wset s) (thr s)" "thr s' t = ⌊(x, w)⌋" "thr s t = None"
shows "∃m. NewThread t x m ∈ set ⦃ta⦄⇘t⇙ ∧ w = no_wait_locks"
using assms
by cases (fastforce split: if_split_asm dest: wset_thread_okD redT_updTs_new_thread)+
lemma redT_ex_new_thread':
assumes "s -t'▹ta→ s'" "thr s' t = ⌊(x, w)⌋" "thr s t = None"
shows "∃m x. NewThread t x m ∈ set ⦃ta⦄⇘t⇙"
using assms
by(cases)(fastforce split: if_split_asm dest!: redT_updTs_new_thread)+
definition deterministic :: "('l,'t,'x,'m,'w) state set ⇒ bool"
where
"deterministic I ⟷
(∀s t x ta' x' m' ta'' x'' m''.
s ∈ I
⟶ thr s t = ⌊(x, no_wait_locks)⌋
⟶ t ⊢ ⟨x, shr s⟩ -ta'→ ⟨x', m'⟩
⟶ t ⊢ ⟨x, shr s⟩ -ta''→ ⟨x'', m''⟩
⟶ actions_ok s t ta' ⟶ actions_ok s t ta''
⟶ ta' = ta'' ∧ x' = x'' ∧ m' = m'') ∧ invariant3p redT I"
lemma determisticI:
"⟦⋀s t x ta' x' m' ta'' x'' m''.
⟦ s ∈ I; thr s t = ⌊(x, no_wait_locks)⌋;
t ⊢ ⟨x, shr s⟩ -ta'→ ⟨x', m'⟩; t ⊢ ⟨x, shr s⟩ -ta''→ ⟨x'', m''⟩;
actions_ok s t ta'; actions_ok s t ta'' ⟧
⟹ ta' = ta'' ∧ x' = x'' ∧ m' = m'';
invariant3p redT I ⟧
⟹ deterministic I"
unfolding deterministic_def by blast
lemma deterministicD:
"⟦ deterministic I;
t ⊢ ⟨x, shr s⟩ -ta'→ ⟨x', m'⟩; t ⊢ ⟨x, shr s⟩ -ta''→ ⟨x'', m''⟩;
thr s t = ⌊(x, no_wait_locks)⌋; actions_ok s t ta'; actions_ok s t ta''; s ∈ I ⟧
⟹ ta' = ta'' ∧ x' = x'' ∧ m' = m''"
unfolding deterministic_def by blast
lemma deterministic_invariant3p:
"deterministic I ⟹ invariant3p redT I"
unfolding deterministic_def by blast
lemma deterministic_THE:
"⟦ deterministic I; thr s t = ⌊(x, no_wait_locks)⌋; t ⊢ ⟨x, shr s⟩ -ta→ ⟨x', m'⟩; actions_ok s t ta; s ∈ I ⟧
⟹ (THE (ta, x', m'). t ⊢ ⟨x, shr s⟩ -ta→ ⟨x', m'⟩ ∧ actions_ok s t ta) = (ta, x', m')"
by(rule the_equality)(blast dest: deterministicD)+
end
locale multithreaded = multithreaded_base +
constrains final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics"
and convert_RA :: "'l released_locks ⇒ 'o list"
assumes new_thread_memory: "⟦ t ⊢ s -ta→ s'; NewThread t' x m ∈ set ⦃ta⦄⇘t⇙ ⟧ ⟹ m = snd s'"
and final_no_red: "⟦ t ⊢ (x, m) -ta→ (x', m'); final x ⟧ ⟹ False"
begin
lemma redT_new_thread_common:
"⟦ s -t▹ta→ s'; NewThread t' x m'' ∈ set ⦃ta⦄⇘t⇙; ⦃ta⦄⇘w⇙ = [] ⟧ ⟹ m'' = shr s'"
by(auto elim!: redT_elims rtrancl3p_cases dest: new_thread_memory)
lemma redT_new_thread:
assumes "s -t'▹ta→ s'" "thr s' t = ⌊(x, w)⌋" "thr s t = None" "⦃ta⦄⇘w⇙ = []"
shows "NewThread t x (shr s') ∈ set ⦃ta⦄⇘t⇙ ∧ w = no_wait_locks"
using assms
apply(cases rule: redT_elims)
apply(auto split: if_split_asm del: conjI elim!: rtrancl3p_cases)
apply(drule (2) redT_updTs_new_thread)
apply(auto dest: new_thread_memory)
done
lemma final_no_redT:
"⟦ s -t▹ta→ s'; thr s t = ⌊(x, no_wait_locks)⌋ ⟧ ⟹ ¬ final x"
by(auto elim!: redT_elims dest: final_no_red)
lemma mfinal_no_redT:
assumes redT: "s -t▹ta→ s'" and mfinal: "mfinal s"
shows False
using redT mfinalD[OF mfinal, of t]
by cases (metis final_no_red, metis neq_no_wait_locks_conv)
end
end
Theory FWProgressAux
section ‹Auxiliary definitions for the progress theorem for the multithreaded semantics›
theory FWProgressAux
imports
FWSemantics
begin
abbreviation collect_waits :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ ('l + 't + 't) set"
where "collect_waits ta ≡ collect_locks ⦃ta⦄⇘l⇙ <+> collect_cond_actions ⦃ta⦄⇘c⇙ <+> collect_interrupts ⦃ta⦄⇘i⇙"
lemma collect_waits_unfold:
"collect_waits ta = {l. Lock ∈ set (⦃ta⦄⇘l⇙ $ l)} <+> {t. Join t ∈ set ⦃ta⦄⇘c⇙} <+> collect_interrupts ⦃ta⦄⇘i⇙"
by(simp add: collect_locks_def)
context multithreaded_base begin
definition must_sync :: "'t ⇒ 'x ⇒ 'm ⇒ bool" ("_ ⊢ ⟨_,/ _⟩/ ≀" [50, 0,0] 81) where
"t ⊢ ⟨x, m⟩ ≀ ⟷ (∃ta x' m' s. t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩ ∧ shr s = m ∧ actions_ok s t ta)"
lemma must_sync_def2:
"t ⊢ ⟨x, m⟩ ≀ ⟷ (∃ta x' m' s. t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩ ∧ actions_ok s t ta)"
by(fastforce simp add: must_sync_def intro: cond_action_oks_shr_change)
lemma must_syncI:
"∃ta x' m' s. t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩ ∧ actions_ok s t ta ⟹ t ⊢ ⟨x, m⟩ ≀"
by(fastforce simp add: must_sync_def2)
lemma must_syncE:
"⟦ t ⊢ ⟨x, m⟩ ≀; ⋀ta x' m' s. ⟦ t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩; actions_ok s t ta; m = shr s ⟧ ⟹ thesis ⟧ ⟹ thesis"
by(fastforce simp only: must_sync_def)
definition can_sync :: "'t ⇒ 'x ⇒ 'm ⇒ ('l + 't + 't) set ⇒ bool" ("_ ⊢ ⟨_,/ _⟩/ _/ ≀" [50,0,0,0] 81) where
"t ⊢ ⟨x, m⟩ LT ≀ ≡ ∃ta x' m'. t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩ ∧ (LT = collect_waits ta)"
lemma can_syncI:
"⟦ t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩;
LT = collect_waits ta ⟧
⟹ t ⊢ ⟨x, m⟩ LT ≀"
by(cases ta)(fastforce simp add: can_sync_def)
lemma can_syncE:
assumes "t ⊢ ⟨x, m⟩ LT ≀"
obtains ta x' m'
where "t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩"
and "LT = collect_waits ta"
using assms
by(clarsimp simp add: can_sync_def)
inductive_set active_threads :: "('l,'t,'x,'m,'w) state ⇒ 't set"
for s :: "('l,'t,'x,'m,'w) state"
where
normal:
"⋀ln. ⟦ thr s t = Some (x, ln);
ln = no_wait_locks;
t ⊢ (x, shr s) -ta→ x'm';
actions_ok s t ta ⟧
⟹ t ∈ active_threads s"
| acquire:
"⋀ln. ⟦ thr s t = Some (x, ln);
ln ≠ no_wait_locks;
¬ waiting (wset s t);
may_acquire_all (locks s) t ln ⟧
⟹ t ∈ active_threads s"
lemma active_threads_iff:
"active_threads s =
{t. ∃x ln. thr s t = Some (x, ln) ∧
(if ln = no_wait_locks
then ∃ta x' m'. t ⊢ (x, shr s) -ta→ (x', m') ∧ actions_ok s t ta
else ¬ waiting (wset s t) ∧ may_acquire_all (locks s) t ln)}"
apply(auto elim!: active_threads.cases intro: active_threads.intros)
apply blast
done
lemma active_thread_ex_red:
assumes "t ∈ active_threads s"
shows "∃ta s'. s -t▹ta→ s'"
using assms
proof cases
case (normal x ta x'm' ln)
with redT_updWs_total[of t "wset s" "⦃ta⦄⇘w⇙"]
show ?thesis
by(cases x'm')(fastforce intro!: redT_normal simp del: split_paired_Ex)
next
case acquire thus ?thesis
by(fastforce intro: redT_acquire simp del: split_paired_Ex simp add: neq_no_wait_locks_conv)
qed
end
text ‹Well-formedness conditions for final›
context final_thread begin
inductive not_final_thread :: "('l,'t,'x,'m,'w) state ⇒ 't ⇒ bool"
for s :: "('l,'t,'x,'m,'w) state" and t :: "'t" where
not_final_thread_final: "⋀ln. ⟦ thr s t = ⌊(x, ln)⌋; ¬ final x ⟧ ⟹ not_final_thread s t"
| not_final_thread_wait_locks: "⋀ln. ⟦ thr s t = ⌊(x, ln)⌋; ln ≠ no_wait_locks ⟧ ⟹ not_final_thread s t"
| not_final_thread_wait_set: "⋀ln. ⟦ thr s t = ⌊(x, ln)⌋; wset s t = ⌊w⌋ ⟧ ⟹ not_final_thread s t"
declare not_final_thread.cases [elim]
lemmas not_final_thread_cases = not_final_thread.cases [consumes 1, case_names final wait_locks wait_set]
lemma not_final_thread_cases2 [consumes 2, case_names final wait_locks wait_set]:
"⋀ln. ⟦ not_final_thread s t; thr s t = ⌊(x, ln)⌋;
¬ final x ⟹ thesis; ln ≠ no_wait_locks ⟹ thesis; ⋀w. wset s t = ⌊w⌋ ⟹ thesis ⟧
⟹ thesis"
by(auto)
lemma not_final_thread_iff:
"not_final_thread s t ⟷ (∃x ln. thr s t = ⌊(x, ln)⌋ ∧ (¬ final x ∨ ln ≠ no_wait_locks ∨ (∃w. wset s t = ⌊w⌋)))"
by(auto intro: not_final_thread.intros)
lemma not_final_thread_conv:
"not_final_thread s t ⟷ thr s t ≠ None ∧ ¬ final_thread s t"
by(auto simp add: final_thread_def intro: not_final_thread.intros)
lemma not_final_thread_existsE:
assumes "not_final_thread s t"
and "⋀x ln. thr s t = ⌊(x, ln)⌋ ⟹ thesis"
shows thesis
using assms by blast
lemma not_final_thread_final_thread_conv:
"thr s t ≠ None ⟹ ¬ final_thread s t ⟷ not_final_thread s t"
by(simp add: not_final_thread_iff final_thread_def)
lemma may_join_cond_action_oks:
assumes "⋀t'. Join t' ∈ set cas ⟹ ¬ not_final_thread s t' ∧ t ≠ t'"
shows "cond_action_oks s t cas"
using assms
proof (induct cas)
case Nil thus ?case by clarsimp
next
case (Cons ca cas)
note IH = ‹⟦ ⋀t'. Join t' ∈ set cas ⟹ ¬ not_final_thread s t' ∧ t ≠ t' ⟧
⟹ cond_action_oks s t cas›
note ass = ‹⋀t'. Join t' ∈ set (ca # cas) ⟹ ¬ not_final_thread s t' ∧ t ≠ t'›
hence "⋀t'. Join t' ∈ set cas ⟹ ¬ not_final_thread s t' ∧ t ≠ t'" by simp
hence "cond_action_oks s t cas" by(rule IH)
moreover have "cond_action_ok s t ca"
proof(cases ca)
case (Join t')
with ass have "¬ not_final_thread s t'" "t ≠ t'" by auto
thus ?thesis using Join by(auto simp add: not_final_thread_iff)
next
case Yield thus ?thesis by simp
qed
ultimately show ?case by simp
qed
end
context multithreaded begin
lemma red_not_final_thread:
"s -t▹ta→ s' ⟹ not_final_thread s t"
by(fastforce elim: redT.cases intro: not_final_thread.intros dest: final_no_red)
lemma redT_preserves_final_thread:
"⟦ s -t'▹ta→ s'; final_thread s t ⟧ ⟹ final_thread s' t"
apply(erule redT.cases)
apply(clarsimp simp add: final_thread_def)
apply(auto simp add: final_thread_def dest: redT_updTs_None redT_updTs_Some final_no_red intro: redT_updWs_None_implies_None)
done
end
context multithreaded_base begin
definition wset_Suspend_ok :: "('l,'t,'x,'m,'w) state set ⇒ ('l,'t,'x,'m,'w) state set"
where
"wset_Suspend_ok I =
{s. s ∈ I ∧
(∀t ∈ dom (wset s). ∃s0∈I. ∃s1∈I. ∃ttas x x0 ta w' ln' ln''. s0 -t▹ta→ s1 ∧ s1 -▹ttas→* s ∧
thr s0 t = ⌊(x0, no_wait_locks)⌋ ∧ t ⊢ ⟨x0, shr s0⟩ -ta→ ⟨x, shr s1⟩ ∧ Suspend w' ∈ set ⦃ta⦄⇘w⇙ ∧
actions_ok s0 t ta ∧ thr s1 t = ⌊(x, ln')⌋ ∧ thr s t = ⌊(x, ln'')⌋)}"
lemma wset_Suspend_okI:
"⟦ s ∈ I;
⋀t w. wset s t = ⌊w⌋ ⟹ ∃s0∈I. ∃s1∈I. ∃ttas x x0 ta w' ln' ln''. s0 -t▹ta→ s1 ∧ s1 -▹ttas→* s ∧
thr s0 t = ⌊(x0, no_wait_locks)⌋ ∧ t ⊢ ⟨x0, shr s0⟩ -ta→ ⟨x, shr s1⟩ ∧ Suspend w' ∈ set ⦃ta⦄⇘w⇙ ∧
actions_ok s0 t ta ∧ thr s1 t = ⌊(x, ln')⌋ ∧ thr s t = ⌊(x, ln'')⌋ ⟧
⟹ s ∈ wset_Suspend_ok I"
unfolding wset_Suspend_ok_def by blast
lemma wset_Suspend_okD1:
"s ∈ wset_Suspend_ok I ⟹ s ∈ I"
unfolding wset_Suspend_ok_def by blast
lemma wset_Suspend_okD2:
"⟦ s ∈ wset_Suspend_ok I; wset s t = ⌊w⌋ ⟧
⟹ ∃s0∈I. ∃s1∈I. ∃ttas x x0 ta w' ln' ln''. s0 -t▹ta→ s1 ∧ s1 -▹ttas→* s ∧
thr s0 t = ⌊(x0, no_wait_locks)⌋ ∧ t ⊢ ⟨x0, shr s0⟩ -ta→ ⟨x, shr s1⟩ ∧ Suspend w' ∈ set ⦃ta⦄⇘w⇙ ∧
actions_ok s0 t ta ∧ thr s1 t = ⌊(x, ln')⌋ ∧ thr s t = ⌊(x, ln'')⌋"
unfolding wset_Suspend_ok_def by blast
lemma wset_Suspend_ok_imp_wset_thread_ok:
"s ∈ wset_Suspend_ok I ⟹ wset_thread_ok (wset s) (thr s)"
apply(rule wset_thread_okI)
apply(rule ccontr)
apply(auto dest: wset_Suspend_okD2)
done
lemma invariant3p_wset_Suspend_ok:
assumes I: "invariant3p redT I"
shows "invariant3p redT (wset_Suspend_ok I)"
proof(rule invariant3pI)
fix s tl s'
assume wso: "s ∈ wset_Suspend_ok I"
and "redT s tl s'"
moreover obtain t' ta where tl: "tl = (t', ta)" by(cases tl)
ultimately have red: "s -t'▹ta→ s'" by simp
moreover from wso have "s ∈ I" by(rule wset_Suspend_okD1)
ultimately have "s' ∈ I" by(rule invariant3pD[OF I])
thus "s' ∈ wset_Suspend_ok I"
proof(rule wset_Suspend_okI)
fix t w
assume ws't: "wset s' t = ⌊w⌋"
show "∃s0∈I. ∃s1∈I. ∃ttas x x0 ta w' ln' ln''. s0 -t▹ta→ s1 ∧ s1 -▹ttas→* s' ∧
thr s0 t = ⌊(x0, no_wait_locks)⌋ ∧ t ⊢ ⟨x0, shr s0⟩ -ta→ ⟨x, shr s1⟩ ∧
Suspend w' ∈ set ⦃ta⦄⇘w⇙ ∧ actions_ok s0 t ta ∧
thr s1 t = ⌊(x, ln')⌋ ∧ thr s' t = ⌊(x, ln'')⌋"
proof(cases "t = t'")
case False
with red ws't obtain w' where wst: "wset s t = ⌊w'⌋"
by cases(auto 4 4 dest: redT_updWs_Some_otherD split: wait_set_status.split_asm)
from wset_Suspend_okD2[OF wso this] obtain s0 s1 ttas x x0 ta' w' ln' ln''
where reuse: "s0 ∈ I" "s1 ∈ I" "s0 -t▹ta'→ s1" "thr s0 t = ⌊(x0, no_wait_locks)⌋"
"t ⊢ ⟨x0, shr s0⟩ -ta'→ ⟨x, shr s1⟩" "Suspend w' ∈ set ⦃ta'⦄⇘w⇙" "actions_ok s0 t ta'" "thr s1 t = ⌊(x, ln')⌋"
and step: "s1 -▹ttas→* s" and tst: "thr s t = ⌊(x, ln'')⌋" by blast
from step red have "s1 -▹ttas@[(t', ta)]→* s'" unfolding RedT_def by(rule rtrancl3p_step)
moreover from red tst False have "thr s' t = ⌊(x, ln'')⌋"
by(cases)(auto intro: redT_updTs_Some)
ultimately show ?thesis using reuse by blast
next
case True
from red show ?thesis
proof(cases)
case (redT_normal x x' m)
note red' = ‹t' ⊢ ⟨x, shr s⟩ -ta→ ⟨x', m⟩›
and tst' = ‹thr s t' = ⌊(x, no_wait_locks)⌋›
and aok = ‹actions_ok s t' ta›
and s' = ‹redT_upd s t' ta x' m s'›
from s' have ws': "redT_updWs t' (wset s) ⦃ta⦄⇘w⇙ (wset s')"
and m: "m = shr s'"
and ts't: "thr s' t' = ⌊(x', redT_updLns (locks s) t' (snd (the (thr s t'))) ⦃ta⦄⇘l⇙)⌋" by auto
from aok have nwait: "¬ waiting (wset s t')"
by(auto simp add: wset_actions_ok_def waiting_def split: if_split_asm)
have "∃w'. Suspend w' ∈ set ⦃ta⦄⇘w⇙"
proof(cases "wset s t")
case None
from redT_updWs_None_SomeD[OF ws', OF ws't None]
show ?thesis ..
next
case (Some w')
with True aok have "Notified ∈ set ⦃ta⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta⦄⇘w⇙"
by(auto simp add: wset_actions_ok_def split: if_split_asm)
with ws' show ?thesis using ws't unfolding True
by(rule redT_updWs_WokenUp_SuspendD)
qed
with tst' ts't aok ‹s ∈ I› ‹s' ∈ I› red red' show ?thesis
unfolding True m by blast
next
case (redT_acquire x n ln)
with ws't True have "wset s t = ⌊w⌋" by auto
from wset_Suspend_okD2[OF wso this] ‹thr s t' = ⌊(x, ln)⌋› True
obtain s0 s1 ttas x0 ta' w' ln' ln''
where reuse: "s0 ∈ I" "s1 ∈ I" "s0 -t▹ta'→ s1" "thr s0 t = ⌊(x0, no_wait_locks)⌋"
"t ⊢ ⟨x0, shr s0⟩ -ta'→ ⟨x, shr s1⟩" "Suspend w' ∈ set ⦃ta'⦄⇘w⇙" "actions_ok s0 t ta'" "thr s1 t = ⌊(x, ln')⌋"
and step: "s1 -▹ttas→* s" by fastforce
from step red have "s1 -▹ttas@[(t', ta)]→* s'" unfolding RedT_def by(rule rtrancl3p_step)
moreover from redT_acquire True have "thr s' t = ⌊(x, no_wait_locks)⌋" by simp
ultimately show ?thesis using reuse by blast
qed
qed
qed
qed
end
end
Theory FWDeadlock
section ‹Deadlock formalisation›
theory FWDeadlock
imports
FWProgressAux
begin
context final_thread begin
definition all_final_except :: "('l,'t,'x,'m,'w) state ⇒ 't set ⇒ bool" where
"all_final_except s Ts ≡ ∀t. not_final_thread s t ⟶ t ∈ Ts"
lemma all_final_except_mono [mono]:
"(⋀x. x ∈ A ⟶ x ∈ B) ⟹ all_final_except ts A ⟶ all_final_except ts B"
by(auto simp add: all_final_except_def)
lemma all_final_except_mono':
"⟦ all_final_except ts A; ⋀x. x ∈ A ⟹ x ∈ B ⟧ ⟹ all_final_except ts B"
by(blast intro: all_final_except_mono[rule_format])
lemma all_final_exceptI:
"(⋀t. not_final_thread s t ⟹ t ∈ Ts) ⟹ all_final_except s Ts"
by(auto simp add: all_final_except_def)
lemma all_final_exceptD:
"⟦ all_final_except s Ts; not_final_thread s t ⟧ ⟹ t ∈ Ts"
by(auto simp add: all_final_except_def)
inductive must_wait :: "('l,'t,'x,'m,'w) state ⇒ 't ⇒ ('l + 't + 't) ⇒ 't set ⇒ bool"
for s :: "('l,'t,'x,'m,'w) state" and t :: "'t" where
"⟦ has_lock (locks s $ l) t'; t' ≠ t; t' ∈ Ts ⟧ ⟹ must_wait s t (Inl l) Ts"
|
"⟦ not_final_thread s t'; t' ∈ Ts ⟧ ⟹ must_wait s t (Inr (Inl t')) Ts"
|
"⟦ all_final_except s Ts; t' ∉ interrupts s ⟧ ⟹ must_wait s t (Inr (Inr t')) Ts"
declare must_wait.cases [elim]
declare must_wait.intros [intro]
lemma must_wait_elims [consumes 1, case_names lock join interrupt, cases pred]:
assumes "must_wait s t lt Ts"
obtains l t' where "lt = Inl l" "has_lock (locks s $ l) t'" "t' ≠ t" "t' ∈ Ts"
| t' where "lt = Inr (Inl t')" "not_final_thread s t'" "t' ∈ Ts"
| t' where "lt = Inr (Inr t')" "all_final_except s Ts" "t' ∉ interrupts s"
using assms
by(auto)
inductive_cases must_wait_elims2 [elim!]:
"must_wait s t (Inl l) Ts"
"must_wait s t (Inr (Inl t'')) Ts"
"must_wait s t (Inr (Inr t'')) Ts"
lemma must_wait_iff:
"must_wait s t lt Ts ⟷
(case lt of Inl l ⇒ ∃t'∈Ts. t ≠ t' ∧ has_lock (locks s $ l) t'
| Inr (Inl t') ⇒ not_final_thread s t' ∧ t' ∈ Ts
| Inr (Inr t') ⇒ all_final_except s Ts ∧ t' ∉ interrupts s)"
by(auto simp add: must_wait.simps split: sum.splits)
end
text‹Deadlock as a system-wide property›
context multithreaded_base begin
definition
deadlock :: "('l,'t,'x,'m,'w) state ⇒ bool"
where
"deadlock s
≡ (∀t x. thr s t = ⌊(x, no_wait_locks)⌋ ∧ ¬ final x ∧ wset s t = None
⟶ t ⊢ ⟨x, shr s⟩ ≀ ∧ (∀LT. t ⊢ ⟨x, shr s⟩ LT ≀ ⟶ (∃lt ∈ LT. must_wait s t lt (dom (thr s)))))
∧ (∀t x ln. thr s t = ⌊(x, ln)⌋ ∧ (∃l. ln $ l > 0) ∧ ¬ waiting (wset s t)
⟶ (∃l t'. ln $ l > 0 ∧ t ≠ t' ∧ thr s t' ≠ None ∧ has_lock (locks s $ l) t'))
∧ (∀t x w. thr s t = ⌊(x, no_wait_locks)⌋ ⟶ wset s t ≠ ⌊PostWS w⌋)"
lemma deadlockI:
"⟦ ⋀t x. ⟦ thr s t = ⌊(x, no_wait_locks)⌋; ¬ final x; wset s t = None ⟧
⟹ t ⊢ ⟨x, shr s⟩ ≀ ∧ (∀LT. t ⊢ ⟨x, shr s⟩ LT ≀ ⟶ (∃lt ∈ LT. must_wait s t lt (dom (thr s))));
⋀t x ln l. ⟦ thr s t = ⌊(x, ln)⌋; ln $ l > 0; ¬ waiting (wset s t) ⟧
⟹ ∃l t'. ln $ l > 0 ∧ t ≠ t' ∧ thr s t' ≠ None ∧ has_lock (locks s $ l) t';
⋀t x w. thr s t = ⌊(x, no_wait_locks)⌋ ⟹ wset s t ≠ ⌊PostWS w⌋ ⟧
⟹ deadlock s"
by(auto simp add: deadlock_def)
lemma deadlockE:
assumes "deadlock s"
obtains "∀t x. thr s t = ⌊(x, no_wait_locks)⌋ ∧ ¬ final x ∧ wset s t = None
⟶ t ⊢ ⟨x, shr s⟩ ≀ ∧ (∀LT. t ⊢ ⟨x, shr s⟩ LT ≀ ⟶ (∃lt ∈ LT. must_wait s t lt (dom (thr s))))"
and "∀t x ln. thr s t = ⌊(x, ln)⌋ ∧ (∃l. ln $ l > 0) ∧ ¬ waiting (wset s t)
⟶ (∃l t'. ln $ l > 0 ∧ t ≠ t' ∧ thr s t' ≠ None ∧ has_lock (locks s $ l) t')"
and "∀t x w. thr s t = ⌊(x, no_wait_locks)⌋ ⟶ wset s t ≠ ⌊PostWS w⌋"
using assms unfolding deadlock_def by(blast)
lemma deadlockD1:
assumes "deadlock s"
and "thr s t = ⌊(x, no_wait_locks)⌋"
and "¬ final x"
and "wset s t = None"
obtains "t ⊢ ⟨x, shr s⟩ ≀"
and "∀LT. t ⊢ ⟨x, shr s⟩ LT ≀ ⟶ (∃lt ∈ LT. must_wait s t lt (dom (thr s)))"
using assms unfolding deadlock_def by(blast)
lemma deadlockD2:
fixes ln
assumes "deadlock s"
and "thr s t = ⌊(x, ln)⌋"
and "ln $ l > 0"
and "¬ waiting (wset s t)"
obtains l' t' where "ln $ l' > 0" "t ≠ t'" "thr s t' ≠ None" "has_lock (locks s $ l') t'"
using assms unfolding deadlock_def by blast
lemma deadlockD3:
assumes "deadlock s"
and "thr s t = ⌊(x, no_wait_locks)⌋"
shows "∀w. wset s t ≠ ⌊PostWS w⌋"
using assms unfolding deadlock_def by blast
lemma deadlock_def2:
"deadlock s ⟷
(∀t x. thr s t = ⌊(x, no_wait_locks)⌋ ∧ ¬ final x ∧ wset s t = None
⟶ t ⊢ ⟨x, shr s⟩ ≀ ∧ (∀LT. t ⊢ ⟨x, shr s⟩ LT ≀ ⟶ (∃lt ∈ LT. must_wait s t lt (dom (thr s)))))
∧ (∀t x ln. thr s t = ⌊(x, ln)⌋ ∧ ln ≠ no_wait_locks ∧ ¬ waiting (wset s t)
⟶ (∃l. ln $ l > 0 ∧ must_wait s t (Inl l) (dom (thr s))))
∧ (∀t x w. thr s t = ⌊(x, no_wait_locks)⌋ ⟶ wset s t ≠ ⌊PostWS WSNotified⌋ ∧ wset s t ≠ ⌊PostWS WSWokenUp⌋)"
unfolding neq_no_wait_locks_conv
apply(rule iffI)
apply(intro strip conjI)
apply(blast dest: deadlockD1)
apply(blast dest: deadlockD1)
apply(blast elim: deadlockD2)
apply(blast dest: deadlockD3)
apply(blast dest: deadlockD3)
apply(elim conjE exE)
apply(rule deadlockI)
apply blast
apply(rotate_tac 1)
apply(erule allE, rotate_tac -1)
apply(erule allE, rotate_tac -1)
apply(erule allE, rotate_tac -1)
apply(erule impE, blast)
apply(elim exE conjE)
apply(erule must_wait.cases)
apply(clarify)
apply(rotate_tac 3)
apply(rule exI conjI|erule not_sym|assumption)+
apply blast
apply blast
apply blast
apply blast
apply(case_tac w)
apply blast
apply blast
done
lemma all_waiting_implies_deadlock:
assumes "lock_thread_ok (locks s) (thr s)"
and normal: "⋀t x. ⟦ thr s t = ⌊(x, no_wait_locks)⌋; ¬ final x; wset s t = None ⟧
⟹ t ⊢ ⟨x, shr s⟩ ≀ ∧ (∀LT. t ⊢ ⟨x, shr s⟩ LT ≀ ⟶ (∃lt ∈ LT. must_wait s t lt (dom (thr s))))"
and acquire: "⋀t x ln l. ⟦ thr s t = ⌊(x, ln)⌋; ¬ waiting (wset s t); ln $ l > 0 ⟧
⟹ ∃l'. ln $ l' > 0 ∧ ¬ may_lock (locks s $ l') t"
and wakeup: "⋀t x w. thr s t = ⌊(x, no_wait_locks)⌋ ⟹ wset s t ≠ ⌊PostWS w⌋"
shows "deadlock s"
proof(rule deadlockI)
fix T X
assume "thr s T = ⌊(X, no_wait_locks)⌋" "¬ final X" "wset s T = None"
thus "T ⊢ ⟨X, shr s⟩ ≀ ∧ (∀LT. T ⊢ ⟨X, shr s⟩ LT ≀ ⟶ (∃lt∈LT. must_wait s T lt (dom (thr s))))"
by(rule normal)
next
fix T X LN l'
assume "thr s T = ⌊(X, LN)⌋"
and "0 < LN $ l'"
and wset: "¬ waiting (wset s T)"
from acquire[OF ‹thr s T = ⌊(X, LN)⌋› wset, OF ‹0 < LN $ l'›]
obtain l' where "0 < LN $ l'" "¬ may_lock (locks s $ l') T" by blast
then obtain t' where "T ≠ t'" "has_lock (locks s $ l') t'"
unfolding not_may_lock_conv by fastforce
moreover with ‹lock_thread_ok (locks s) (thr s)›
have "thr s t' ≠ None" by(auto dest: lock_thread_okD)
ultimately show "∃l t'. 0 < LN $ l ∧ T ≠ t' ∧ thr s t' ≠ None ∧ has_lock (locks s $ l) t'"
using ‹0 < LN $ l'› by(auto)
qed(rule wakeup)
lemma mfinal_deadlock:
"mfinal s ⟹ deadlock s"
unfolding mfinal_def2
by(rule deadlockI)(auto simp add: final_thread_def)
text ‹Now deadlock for single threads›
lemma must_wait_mono:
"(⋀x. x ∈ A ⟶ x ∈ B) ⟹ must_wait s t lt A ⟶ must_wait s t lt B"
by(auto simp add: must_wait_iff split: sum.split elim: all_final_except_mono')
lemma must_wait_mono':
"⟦ must_wait s t lt A; A ⊆ B ⟧ ⟹ must_wait s t lt B"
using must_wait_mono[of A B s t lt]
by blast
end
lemma UN_mono: "⟦ x ∈ A ⟶ x ∈ A'; x ∈ B ⟶ x ∈ B' ⟧ ⟹ x ∈ A ∪ B ⟶ x ∈ A' ∪ B'"
by blast
lemma Collect_mono_conv [mono]: "x ∈ {x. P x} ⟷ P x"
by blast
context multithreaded_base begin
coinductive_set deadlocked :: "('l,'t,'x,'m,'w) state ⇒ 't set"
for s :: "('l,'t,'x,'m,'w) state" where
deadlockedLock:
"⟦ thr s t = ⌊(x, no_wait_locks)⌋; t ⊢ ⟨x, shr s⟩ ≀; wset s t = None;
⋀LT. t ⊢ ⟨x, shr s⟩ LT ≀ ⟹ ∃lt ∈ LT. must_wait s t lt (deadlocked s ∪ final_threads s) ⟧
⟹ t ∈ deadlocked s"
| deadlockedWait:
"⋀ln. ⟦ thr s t = ⌊(x, ln)⌋; all_final_except s (deadlocked s); waiting (wset s t) ⟧ ⟹ t ∈ deadlocked s"
| deadlockedAcquire:
"⋀ln. ⟦ thr s t = ⌊(x, ln)⌋; ¬ waiting (wset s t); ln $ l > 0; has_lock (locks s $ l) t'; t' ≠ t;
t' ∈ deadlocked s ∨ final_thread s t' ⟧
⟹ t ∈ deadlocked s"
monos must_wait_mono UN_mono
lemma deadlockedAcquire_must_wait:
"⋀ln. ⟦ thr s t = ⌊(x, ln)⌋; ¬ waiting (wset s t); ln $ l > 0; must_wait s t (Inl l) (deadlocked s ∪ final_threads s) ⟧
⟹ t ∈ deadlocked s"
apply(erule must_wait_elims)
apply(erule (2) deadlockedAcquire)
apply auto
done
lemma deadlocked_elims [consumes 1, case_names lock wait acquire]:
assumes "t ∈ deadlocked s"
and lock: "⋀x. ⟦ thr s t = ⌊(x, no_wait_locks)⌋; t ⊢ ⟨x, shr s⟩ ≀; wset s t = None;
⋀LT. t ⊢ ⟨x, shr s⟩ LT ≀ ⟹ ∃lt ∈ LT. must_wait s t lt (deadlocked s ∪ final_threads s) ⟧
⟹ thesis"
and wait: "⋀x ln. ⟦ thr s t = ⌊(x, ln)⌋; all_final_except s (deadlocked s); waiting (wset s t) ⟧
⟹ thesis"
and acquire: "⋀x ln l t'.
⟦ thr s t = ⌊(x, ln)⌋; ¬ waiting (wset s t); 0 < ln $ l; has_lock (locks s $ l) t'; t ≠ t';
t' ∈ deadlocked s ∨ final_thread s t' ⟧ ⟹ thesis"
shows thesis
using assms by cases blast+
lemma deadlocked_coinduct
[consumes 1, case_names deadlocked, case_conclusion deadlocked Lock Wait Acquire, coinduct set: deadlocked]:
assumes major: "t ∈ X"
and step:
"⋀t. t ∈ X ⟹
(∃x. thr s t = ⌊(x, no_wait_locks)⌋ ∧ t ⊢ ⟨x, shr s⟩ ≀ ∧ wset s t = None ∧
(∀LT. t ⊢ ⟨x, shr s⟩ LT ≀ ⟶ (∃lt∈LT. must_wait s t lt (X ∪ deadlocked s ∪ final_threads s)))) ∨
(∃x ln. thr s t = ⌊(x, ln)⌋ ∧ all_final_except s (X ∪ deadlocked s) ∧ waiting (wset s t)) ∨
(∃x l t' ln. thr s t = ⌊(x, ln)⌋ ∧ ¬ waiting (wset s t) ∧ 0 < ln $ l ∧ has_lock (locks s $ l) t' ∧
t' ≠ t ∧ ((t' ∈ X ∨ t' ∈ deadlocked s) ∨ final_thread s t'))"
shows "t ∈ deadlocked s"
using major
proof(coinduct)
case (deadlocked t)
have "X ∪ deadlocked s ∪ final_threads s = {x. x ∈ X ∨ x ∈ deadlocked s ∨ x ∈ final_threads s}"
by auto
moreover have "X ∪ deadlocked s = {x. x ∈ X ∨ x ∈ deadlocked s}" by blast
ultimately show ?case using step[OF deadlocked] by(elim disjE) simp_all
qed
definition deadlocked' :: "('l,'t,'x,'m,'w) state ⇒ bool" where
"deadlocked' s ≡ (∀t. not_final_thread s t ⟶ t ∈ deadlocked s)"
lemma deadlocked'I:
"(⋀t. not_final_thread s t ⟹ t ∈ deadlocked s) ⟹ deadlocked' s"
by(auto simp add: deadlocked'_def)
lemma deadlocked'D2:
"⟦ deadlocked' s; not_final_thread s t; t ∈ deadlocked s ⟹ thesis ⟧ ⟹ thesis"
by(auto simp add: deadlocked'_def)
lemma not_deadlocked'I:
"⟦ not_final_thread s t; t ∉ deadlocked s ⟧ ⟹ ¬ deadlocked' s"
by(auto dest: deadlocked'D2)
lemma deadlocked'_intro:
"⟦ ∀t. not_final_thread s t ⟶ t ∈ deadlocked s ⟧ ⟹ deadlocked' s"
by(rule deadlocked'I)(blast)+
lemma deadlocked_thread_exists:
assumes "t ∈ deadlocked s"
and "⋀x ln. thr s t = ⌊(x, ln)⌋ ⟹ thesis"
shows thesis
using assms
by cases blast+
end
context multithreaded begin
lemma red_no_deadlock:
assumes P: "s -t▹ta→ s'"
and dead: "t ∈ deadlocked s"
shows False
proof -
from P show False
proof(cases)
case (redT_normal x x' m')
note red = ‹t ⊢ ⟨x, shr s⟩ -ta→ ⟨x', m'⟩›
note tst = ‹thr s t = ⌊(x, no_wait_locks)⌋›
note aok = ‹actions_ok s t ta›
show False
proof(cases "∃w. wset s t = ⌊InWS w⌋")
case True with aok show ?thesis by(auto simp add: wset_actions_ok_def split: if_split_asm)
next
case False
with dead tst
have mle: "t ⊢ ⟨x, shr s⟩ ≀"
and cledead: "∀LT. t ⊢ ⟨x, shr s⟩ LT ≀ ⟶ (∃lt ∈ LT. must_wait s t lt (deadlocked s ∪ final_threads s))"
by(cases, auto simp add: waiting_def)+
let ?LT = "collect_waits ta"
from red have "t ⊢ ⟨x, shr s⟩ ?LT ≀" by(auto intro: can_syncI)
then obtain lt where lt: "lt ∈ ?LT" and mw: "must_wait s t lt (deadlocked s ∪ final_threads s)"
by(blast dest: cledead[rule_format])
from mw show False
proof(cases rule: must_wait_elims)
case (lock l t')
from ‹lt = Inl l› lt have "l ∈ collect_locks ⦃ta⦄⇘l⇙" by(auto)
with aok have "may_lock (locks s $ l) t"
by(auto elim!: collect_locksE lock_ok_las_may_lock)
with ‹has_lock (locks s $ l) t'› have "t' = t"
by(auto dest: has_lock_may_lock_t_eq)
with ‹t' ≠ t› show False by contradiction
next
case (join t')
from ‹lt = Inr (Inl t')› lt have "Join t' ∈ set ⦃ta⦄⇘c⇙" by auto
from ‹not_final_thread s t'› obtain x'' ln''
where "thr s t' = ⌊(x'', ln'')⌋" by(rule not_final_thread_existsE)
moreover with ‹Join t' ∈ set ⦃ta⦄⇘c⇙› aok
have "final x''" "ln'' = no_wait_locks" "wset s t' = None"
by(auto dest: cond_action_oks_Join)
ultimately show False using ‹not_final_thread s t'› by(auto)
next
case (interrupt t')
from aok lt ‹lt = Inr (Inr t')›
have "t' ∈ interrupts s"
by(auto intro: collect_interrupts_interrupted)
with ‹t' ∉ interrupts s› show False by contradiction
qed
qed
next
case (redT_acquire x n ln)
show False
proof(cases "∃w. wset s t = ⌊InWS w⌋")
case True with ‹¬ waiting (wset s t)› show ?thesis
by(auto simp add: not_waiting_iff)
next
case False
with dead ‹thr s t = ⌊(x, ln)⌋› ‹0 < ln $ n›
obtain l t' where "0 < ln $ l" "t ≠ t'"
and "has_lock (locks s $ l) t'"
by(cases)(fastforce simp add: waiting_def)+
hence "¬ may_acquire_all (locks s) t ln"
by(auto elim: may_acquire_allE dest: has_lock_may_lock_t_eq)
with ‹may_acquire_all (locks s) t ln› show ?thesis by contradiction
qed
qed
qed
lemma deadlocked'_no_red:
"⟦ s -t▹ta→ s'; deadlocked' s ⟧ ⟹ False"
apply(rule red_no_deadlock)
apply(assumption)
apply(erule deadlocked'D2)
by(rule red_not_final_thread)
lemma not_final_thread_deadlocked_final_thread [iff]:
"thr s t = ⌊xln⌋ ⟹ not_final_thread s t ∨ t ∈ deadlocked s ∨ final_thread s t"
by(auto simp add: not_final_thread_final_thread_conv[symmetric])
lemma all_waiting_deadlocked:
assumes "not_final_thread s t"
and "lock_thread_ok (locks s) (thr s)"
and normal: "⋀t x. ⟦ thr s t = ⌊(x, no_wait_locks)⌋; ¬ final x; wset s t = None ⟧
⟹ t ⊢ ⟨x, shr s⟩ ≀ ∧ (∀LT. t ⊢ ⟨x, shr s⟩ LT ≀ ⟶ (∃lt∈LT. must_wait s t lt (final_threads s)))"
and acquire: "⋀t x ln l. ⟦ thr s t = ⌊(x, ln)⌋; ¬ waiting (wset s t); ln $ l > 0 ⟧
⟹ ∃l'. ln $ l' > 0 ∧ ¬ may_lock (locks s $ l') t"
and wakeup: "⋀t x w. thr s t = ⌊(x, no_wait_locks)⌋ ⟹ wset s t ≠ ⌊PostWS w⌋"
shows "t ∈ deadlocked s"
proof -
from ‹not_final_thread s t›
have "t ∈ {t. not_final_thread s t}" by simp
thus ?thesis
proof(coinduct)
case (deadlocked z)
hence "not_final_thread s z" by simp
then obtain x' ln' where "thr s z = ⌊(x', ln')⌋" by(fastforce elim!: not_final_thread_existsE)
{
assume "wset s z = None" "¬ final x'"
and [simp]: "ln' = no_wait_locks"
with ‹thr s z = ⌊(x', ln')⌋›
have "z ⊢ ⟨x', shr s⟩ ≀ ∧ (∀LT. z ⊢ ⟨x', shr s⟩ LT ≀ ⟶ (∃lt ∈ LT. must_wait s z lt (final_threads s)))"
by(auto dest: normal)
then obtain "z ⊢ ⟨x', shr s⟩ ≀"
and clnml: "⋀LT. z ⊢ ⟨x', shr s⟩ LT ≀ ⟹ ∃lt ∈ LT. must_wait s z lt (final_threads s)" by(blast)
{ fix LT
assume "z ⊢ ⟨x', shr s⟩ LT ≀"
then obtain lt where mw: "must_wait s z lt (final_threads s)" and lt: "lt ∈ LT"
by(blast dest: clnml)
from mw have "must_wait s z lt ({t. not_final_thread s t} ∪ deadlocked s ∪ final_threads s)"
by(blast intro: must_wait_mono')
with lt have "∃lt ∈ LT. must_wait s z lt ({t. not_final_thread s t} ∪ deadlocked s ∪ final_threads s)"
by blast }
with ‹z ⊢ ⟨x', shr s⟩ ≀› ‹thr s z = ⌊(x', ln')⌋› ‹wset s z = None› have ?case by(simp) }
note c1 = this
{
assume wsz: "¬ waiting (wset s z)"
and "ln' ≠ no_wait_locks"
from ‹ln' ≠ no_wait_locks› obtain l where "0 < ln' $ l"
by(auto simp add: neq_no_wait_locks_conv)
with wsz ‹thr s z = ⌊(x', ln')⌋›
obtain l' where "0 < ln' $ l'" "¬ may_lock (locks s $ l') z"
by(blast dest: acquire)
then obtain t'' where "t'' ≠ z" "has_lock (locks s $ l') t''"
unfolding not_may_lock_conv by blast
with ‹lock_thread_ok (locks s) (thr s)›
obtain x'' ln'' where "thr s t'' = ⌊(x'', ln'')⌋"
by(auto elim!: lock_thread_ok_has_lockE)
hence "(not_final_thread s t'' ∨ t'' ∈ deadlocked s) ∨ final_thread s t''"
by(clarsimp simp add: not_final_thread_iff final_thread_def)
with wsz ‹0 < ln' $ l'› ‹thr s z = ⌊(x', ln')⌋› ‹t'' ≠ z› ‹has_lock (locks s $ l') t''›
have ?Acquire by simp blast
hence ?case by simp }
note c2 = this
{ fix w
assume "waiting (wset s z)"
with ‹thr s z = ⌊(x', ln')⌋›
have "?Wait" by(clarsimp simp add: all_final_except_def)
hence ?case by simp }
note c3 = this
from ‹not_final_thread s z› ‹thr s z = ⌊(x', ln')⌋› show ?case
proof(cases rule: not_final_thread_cases2)
case final show ?thesis
proof(cases "wset s z")
case None show ?thesis
proof(cases "ln' = no_wait_locks")
case True with None final show ?thesis by(rule c1)
next
case False
from None have "¬ waiting (wset s z)" by(simp add: not_waiting_iff)
thus ?thesis using False by(rule c2)
qed
next
case (Some w)
show ?thesis
proof(cases w)
case (InWS w')
with Some have "waiting (wset s z)" by(simp add: waiting_def)
thus ?thesis by(rule c3)
next
case (PostWS w')
with Some have "¬ waiting (wset s z)" by(simp add: not_waiting_iff)
moreover from PostWS ‹thr s z = ⌊(x', ln')⌋› Some
have "ln' ≠ no_wait_locks" by(auto dest: wakeup)
ultimately show ?thesis by(rule c2)
qed
qed
next
case wait_locks show ?thesis
proof(cases "wset s z")
case None
hence "¬ waiting (wset s z)" by(simp add: not_waiting_iff)
thus ?thesis using wait_locks by(rule c2)
next
case (Some w)
show ?thesis
proof(cases w)
case (InWS w')
with Some have "waiting (wset s z)" by(simp add: waiting_def)
thus ?thesis by(rule c3)
next
case (PostWS w')
with Some have "¬ waiting (wset s z)" by(simp add: not_waiting_iff)
moreover from PostWS ‹thr s z = ⌊(x', ln')⌋› Some
have "ln' ≠ no_wait_locks" by(auto dest: wakeup)
ultimately show ?thesis by(rule c2)
qed
qed
next
case (wait_set w)
show ?thesis
proof(cases w)
case (InWS w')
with wait_set have "waiting (wset s z)" by(simp add: waiting_def)
thus ?thesis by(rule c3)
next
case (PostWS w')
with wait_set have "¬ waiting (wset s z)" by(simp add: not_waiting_iff)
moreover from PostWS ‹thr s z = ⌊(x', ln')⌋› wait_set
have "ln' ≠ no_wait_locks" by(auto dest: wakeup[simplified])
ultimately show ?thesis by(rule c2)
qed
qed
qed
qed
text ‹Equivalence proof for both notions of deadlock›
lemma deadlock_implies_deadlocked':
assumes dead: "deadlock s"
shows "deadlocked' s"
proof -
show ?thesis
proof(rule deadlocked'I)
fix t
assume "not_final_thread s t"
hence "t ∈ {t. not_final_thread s t}" ..
thus "t ∈ deadlocked s"
proof(coinduct)
case (deadlocked t'')
hence "not_final_thread s t''" ..
then obtain x'' ln'' where tst'': "thr s t'' = ⌊(x'', ln'')⌋"
by(rule not_final_thread_existsE)
{ assume "waiting (wset s t'')"
moreover
with tst'' have nfine: "not_final_thread s t''"
unfolding waiting_def
by(blast intro: not_final_thread.intros)
ultimately have ?case using tst''
by(blast intro: all_final_exceptI not_final_thread_final) }
note c1 = this
{
assume wst'': "¬ waiting (wset s t'')"
and "ln'' ≠ no_wait_locks"
then obtain l where l: "ln'' $ l > 0"
by(auto simp add: neq_no_wait_locks_conv)
with dead wst'' tst'' obtain l' T
where "ln'' $ l' > 0" "t'' ≠ T"
and hl: "has_lock (locks s $ l') T"
and tsT: "thr s T ≠ None"
by - (erule deadlockD2)
moreover from ‹thr s T ≠ None›
obtain xln where tsT: "thr s T = ⌊xln⌋" by auto
then obtain X LN where "thr s T = ⌊(X, LN)⌋"
by(cases xln, auto)
moreover hence "not_final_thread s T ∨ final_thread s T"
by(auto simp add: final_thread_def not_final_thread_iff)
ultimately have ?case using wst'' tst'' by blast }
note c2 = this
{ assume "wset s t'' = None"
and [simp]: "ln'' = no_wait_locks"
moreover
with ‹not_final_thread s t''› tst''
have "¬ final x''" by(auto)
ultimately obtain "t'' ⊢ ⟨x'', shr s⟩ ≀"
and clnml: "⋀LT. t'' ⊢ ⟨x'', shr s⟩ LT ≀ ⟹ ∃t'. thr s t' ≠ None ∧ (∃lt∈LT. must_wait s t'' lt (dom (thr s)))"
using ‹thr s t'' = ⌊(x'', ln'')⌋› ‹deadlock s›
by(blast elim: deadlockD1)
{ fix LT
assume "t'' ⊢ ⟨x'', shr s⟩ LT ≀"
then obtain lt where lt: "lt ∈ LT"
and mw: "must_wait s t'' lt (dom (thr s))"
by(blast dest: clnml)
note mw
also have "dom (thr s) = {t. not_final_thread s t} ∪ deadlocked s ∪ final_threads s"
by(auto simp add: not_final_thread_conv dest: deadlocked_thread_exists elim: final_threadE)
finally have "∃lt∈LT. must_wait s t'' lt ({t. not_final_thread s t} ∪ deadlocked s ∪ final_threads s)"
using lt by blast }
with ‹t'' ⊢ ⟨x'', shr s⟩ ≀› tst'' ‹wset s t'' = None› have ?case by(simp) }
note c3 = this
from ‹not_final_thread s t''› tst'' show ?case
proof(cases rule: not_final_thread_cases2)
case final show ?thesis
proof(cases "wset s t''")
case None show ?thesis
proof(cases "ln'' = no_wait_locks")
case True with None show ?thesis by(rule c3)
next
case False
from None have "¬ waiting (wset s t'')" by(simp add: not_waiting_iff)
thus ?thesis using False by(rule c2)
qed
next
case (Some w)
show ?thesis
proof(cases w)
case (InWS w')
with Some have "waiting (wset s t'')" by(simp add: waiting_def)
thus ?thesis by(rule c1)
next
case (PostWS w')
hence "¬ waiting (wset s t'')" using Some by(simp add: not_waiting_iff)
moreover from PostWS Some tst''
have "ln'' ≠ no_wait_locks" by(auto dest: deadlockD3[OF dead])
ultimately show ?thesis by(rule c2)
qed
qed
next
case wait_locks show ?thesis
proof(cases "waiting (wset s t'')")
case False
thus ?thesis using wait_locks by(rule c2)
next
case True thus ?thesis by(rule c1)
qed
next
case (wait_set w)
show ?thesis
proof(cases w)
case InWS
with wait_set have "waiting (wset s t'')" by(simp add: waiting_def)
thus ?thesis by(rule c1)
next
case (PostWS w')
hence "¬ waiting (wset s t'')" using wait_set
by(simp add: not_waiting_iff)
moreover from PostWS wait_set tst''
have "ln'' ≠ no_wait_locks" by(auto dest: deadlockD3[OF dead])
ultimately show ?thesis by(rule c2)
qed
qed
qed
qed
qed
lemma deadlocked'_implies_deadlock:
assumes dead: "deadlocked' s"
shows "deadlock s"
proof -
have deadlocked: "⋀t. not_final_thread s t ⟹ t ∈ deadlocked s"
using dead by(rule deadlocked'D2)
show ?thesis
proof(rule deadlockI)
fix t' x'
assume "thr s t' = ⌊(x', no_wait_locks)⌋"
and "¬ final x'"
and "wset s t' = None"
hence "not_final_thread s t'" by(auto intro: not_final_thread_final)
hence "t' ∈ deadlocked s" by(rule deadlocked)
thus "t' ⊢ ⟨x', shr s⟩ ≀ ∧ (∀LT. t' ⊢ ⟨x', shr s⟩ LT ≀ ⟶ (∃lt ∈ LT. must_wait s t' lt (dom (thr s))))"
proof(cases rule: deadlocked_elims)
case (lock x'')
note lock = ‹⋀LT. t' ⊢ ⟨x'', shr s⟩ LT ≀ ⟹ ∃lt ∈ LT. must_wait s t' lt (deadlocked s ∪ final_threads s)›
from ‹thr s t' = ⌊(x'', no_wait_locks)⌋› ‹thr s t' = ⌊(x', no_wait_locks)⌋›
have [simp]: "x' = x''" by auto
{ fix LT
assume "t' ⊢ ⟨x'', shr s⟩ LT ≀"
from lock[OF this] obtain lt where lt: "lt ∈ LT"
and mw: "must_wait s t' lt (deadlocked s ∪ final_threads s)" by blast
have "deadlocked s ∪ final_threads s ⊆ dom (thr s)"
by(auto elim: final_threadE dest: deadlocked_thread_exists)
with mw have "must_wait s t' lt (dom (thr s))" by(rule must_wait_mono')
with lt have "∃lt∈LT. must_wait s t' lt (dom (thr s))" by blast }
with ‹t' ⊢ ⟨x'', shr s⟩ ≀› show ?thesis by(auto)
next
case (wait x'' ln'')
from ‹wset s t' = None› ‹waiting (wset s t')›
have False by(simp add: waiting_def)
thus ?thesis ..
next
case (acquire x'' ln'' l'' T)
from ‹thr s t' = ⌊(x'', ln'')⌋› ‹thr s t' = ⌊(x', no_wait_locks)⌋› ‹0 < ln'' $ l''›
have False by(auto)
thus ?thesis ..
qed
next
fix t' x' ln' l
assume "thr s t' = ⌊(x', ln')⌋"
and "0 < ln' $ l"
and wst': "¬ waiting (wset s t')"
hence "not_final_thread s t'" by(auto intro: not_final_thread_wait_locks)
hence "t' ∈ deadlocked s" by(rule deadlocked)
thus "∃l T. 0 < ln' $ l ∧ t' ≠ T ∧ thr s T ≠ None ∧ has_lock (locks s $ l) T"
proof(cases rule: deadlocked_elims)
case (lock x'')
from ‹thr s t' = ⌊(x', ln')⌋› ‹thr s t' = ⌊(x'', no_wait_locks)⌋› ‹0 < ln' $ l›
have False by auto
thus ?thesis ..
next
case (wait x' ln')
from wst' ‹waiting (wset s t')›
have False by contradiction
thus ?thesis ..
next
case (acquire x'' ln'' l'' t'')
from ‹thr s t' = ⌊(x'', ln'')⌋› ‹thr s t' = ⌊(x', ln')⌋›
have [simp]: "x' = x''" "ln' = ln''" by auto
moreover from ‹t'' ∈ deadlocked s ∨ final_thread s t''›
have "thr s t'' ≠ None"
by(auto elim: deadlocked_thread_exists simp add: final_thread_def)
with ‹0 < ln'' $ l''› ‹has_lock (locks s $ l'') t''› ‹t' ≠ t''› ‹thr s t' = ⌊(x'', ln'')⌋›
show ?thesis by auto
qed
next
fix t x w
assume tst: "thr s t = ⌊(x, no_wait_locks)⌋"
show "wset s t ≠ ⌊PostWS w⌋"
proof
assume "wset s t = ⌊PostWS w⌋"
moreover with tst have "not_final_thread s t"
by(auto simp add: not_final_thread_iff)
hence "t ∈ deadlocked s" by(rule deadlocked)
ultimately show False using tst
by(auto elim: deadlocked.cases simp add: waiting_def)
qed
qed
qed
lemma deadlock_eq_deadlocked':
"deadlock = deadlocked'"
by(rule ext)(auto intro: deadlock_implies_deadlocked' deadlocked'_implies_deadlock)
lemma deadlock_no_red:
"⟦ s -t▹ta→ s'; deadlock s ⟧ ⟹ False"
unfolding deadlock_eq_deadlocked'
by(rule deadlocked'_no_red)
lemma deadlock_no_active_threads:
assumes dead: "deadlock s"
shows "active_threads s = {}"
proof(rule equals0I)
fix t
assume active: "t ∈ active_threads s"
then obtain ta s' where "s -t▹ta→ s'" by(auto dest: active_thread_ex_red)
thus False using dead by(rule deadlock_no_red)
qed
end
locale preserve_deadlocked = multithreaded final r convert_RA
for final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics" ("_ ⊢ _ -_→ _" [50,0,0,50] 80)
and convert_RA :: "'l released_locks ⇒ 'o list"
+
fixes wf_state :: "('l,'t,'x,'m,'w) state set"
assumes invariant3p_wf_state: "invariant3p redT wf_state"
assumes can_lock_preserved:
"⟦ s ∈ wf_state; s -t'▹ta'→ s';
thr s t = ⌊(x, no_wait_locks)⌋; t ⊢ ⟨x, shr s⟩ ≀ ⟧
⟹ t ⊢ ⟨x, shr s'⟩ ≀"
and can_lock_devreserp:
"⟦ s ∈ wf_state; s -t'▹ta'→ s';
thr s t = ⌊(x, no_wait_locks)⌋; t ⊢ ⟨x, shr s'⟩ L ≀ ⟧
⟹ ∃L'⊆L. t ⊢ ⟨x, shr s⟩ L' ≀"
begin
lemma redT_deadlocked_subset:
assumes wfs: "s ∈ wf_state"
and Red: "s -t▹ta→ s'"
shows "deadlocked s ⊆ deadlocked s'"
proof
fix t'
assume t'dead: "t' ∈ deadlocked s"
from Red have tndead: "t ∉ deadlocked s"
by(auto dest: red_no_deadlock)
with t'dead have t't: "t' ≠ t" by auto
{ fix t'
assume "final_thread s t'"
then obtain x' ln' where tst': "thr s t' = ⌊(x', ln')⌋" by(auto elim!: final_threadE)
with ‹final_thread s t'› have "final x'"
and "wset s t' = None" and [simp]: "ln' = no_wait_locks"
by(auto elim: final_threadE)
with Red tst' have "t ≠ t'" by cases(auto dest: final_no_red)
with Red tst' have "thr s' t' = ⌊(x', ln')⌋"
by cases(auto intro: redT_updTs_Some)
moreover from Red ‹t ≠ t'› ‹wset s t' = None›
have "wset s' t' = None" by cases(auto simp: redT_updWs_None_implies_None)
ultimately have "final_thread s' t'" using tst' ‹final x'›
by(auto simp add: final_thread_def) }
hence subset: "deadlocked s ∪ final_threads s ⊆ deadlocked s ∪ deadlocked s' ∪ final_threads s'" by(auto)
from Red show "t' ∈ deadlocked s'"
proof(cases)
case (redT_normal x x' m')
note red = ‹t ⊢ ⟨x, shr s⟩ -ta→ ⟨x', m'⟩›
and tst = ‹thr s t = ⌊(x, no_wait_locks)⌋›
and aok = ‹actions_ok s t ta›
and s' = ‹redT_upd s t ta x' m' s'›
from red have "¬ final x" by(auto dest: final_no_red)
with tndead tst have nafe: "¬ all_final_except s (deadlocked s)"
by(fastforce simp add: all_final_except_def not_final_thread_iff)
from t'dead show ?thesis
proof(coinduct)
case (deadlocked t'')
note t''dead = this
with Red have t''t: "t'' ≠ t"
by(auto dest: red_no_deadlock)
from t''dead show ?case
proof(cases rule: deadlocked_elims)
case (lock X)
hence est'': "thr s t'' = ⌊(X, no_wait_locks)⌋"
and msE: "t'' ⊢ ⟨X, shr s⟩ ≀"
and csexdead: "⋀LT. t'' ⊢ ⟨X, shr s⟩ LT ≀ ⟹ ∃lt ∈ LT. must_wait s t'' lt (deadlocked s ∪ final_threads s)"
by auto
from t''t Red est''
have es't'': "thr s' t'' = ⌊(X, no_wait_locks)⌋"
by(cases s)(cases s', auto elim!: redT_ts_Some_inv)
note es't'' moreover
from wfs Red est'' msE have msE': "t'' ⊢ ⟨X, shr s'⟩ ≀" by(rule can_lock_preserved)
moreover
{ fix LT
assume clL'': "t'' ⊢ ⟨X, shr s'⟩ LT ≀"
with est'' have "∃LT'⊆LT. t'' ⊢ ⟨X, shr s⟩ LT' ≀"
by(rule can_lock_devreserp[OF wfs Red])
then obtain LT' where clL': "t'' ⊢ ⟨X, shr s⟩ LT' ≀"
and LL': "LT' ⊆ LT" by blast
with csexdead obtain lt
where lt: "lt ∈ LT" and mw: "must_wait s t'' lt (deadlocked s ∪ final_threads s)"
by blast
from mw have "must_wait s' t'' lt (deadlocked s ∪ deadlocked s' ∪ final_threads s')"
proof(cases rule: must_wait_elims)
case (lock l t')
from ‹t' ∈ deadlocked s ∪ final_threads s› Red have tt': "t ≠ t'"
by(auto dest: red_no_deadlock final_no_redT elim: final_threadE)
from aok have "lock_actions_ok (locks s $ l) t (⦃ta⦄⇘l⇙ $ l)"
by(auto simp add: lock_ok_las_def)
with tt' ‹has_lock (locks s $ l) t'› s'
have hl't': "has_lock (locks s' $ l) t'" by(auto)
moreover note ‹t' ≠ t''›
moreover from ‹t' ∈ deadlocked s ∪ final_threads s›
have "t' ∈ (deadlocked s ∪ deadlocked s' ∪ final_threads s')"
using subset by blast
ultimately show ?thesis unfolding ‹lt = Inl l› ..
next
case (join t')
note t'dead = ‹t' ∈ deadlocked s ∪ final_threads s›
with Red have tt': "t ≠ t'"
by(auto dest: red_no_deadlock final_no_redT elim: final_threadE)
note nftt' = ‹not_final_thread s t'›
from t'dead Red aok s' tt' have ts't': "thr s' t' = thr s t'"
by(auto elim!: deadlocked_thread_exists final_threadE intro: redT_updTs_Some)
from nftt' have "thr s t' ≠ None" by auto
with nftt' t'dead have "t' ∈ deadlocked s"
by(simp add: not_final_thread_final_thread_conv[symmetric])
hence "not_final_thread s' t'"
proof(cases rule: deadlocked_elims)
case (lock x'')
from ‹t' ⊢ ⟨x'', shr s⟩ ≀› have "¬ final x''"
by(auto elim: must_syncE dest: final_no_red)
with ‹thr s t' = ⌊(x'', no_wait_locks)⌋› ts't' show ?thesis
by(auto intro: not_final_thread.intros)
next
case (wait x'' ln'')
from ‹¬ final x› tst ‹all_final_except s (deadlocked s)›
have "t ∈ deadlocked s" by(fastforce dest: all_final_exceptD simp add: not_final_thread_iff)
with Red have False by(auto dest: red_no_deadlock)
thus ?thesis ..
next
case (acquire x'' ln'' l'' T'')
from ‹thr s t' = ⌊(x'', ln'')⌋› ‹0 < ln'' $ l''› ts't'
show ?thesis by(auto intro: not_final_thread.intros(2))
qed
moreover from t'dead subset have "t' ∈ deadlocked s ∪ deadlocked s' ∪ final_threads s'" ..
ultimately show ?thesis unfolding ‹lt = Inr (Inl t')› ..
next
case (interrupt t')
from tst red aok have "not_final_thread s t"
by(auto simp add: wset_actions_ok_def not_final_thread_iff split: if_split_asm dest: final_no_red)
with ‹all_final_except s (deadlocked s ∪ final_threads s)›
have "t ∈ deadlocked s ∪ final_threads s" by(rule all_final_exceptD)
moreover have "t ∉ deadlocked s" using Red by(blast dest: red_no_deadlock)
moreover have "¬ final_thread s t" using red tst by(auto simp add: final_thread_def dest: final_no_red)
ultimately have False by blast
thus ?thesis ..
qed
with lt have "∃lt∈LT. must_wait s' t'' lt (deadlocked s ∪ deadlocked s' ∪ final_threads s')" by blast }
moreover have "wset s' t'' = None" using s' t''t ‹wset s t'' = None›
by(auto intro: redT_updWs_None_implies_None)
ultimately show ?thesis by(auto)
next
case (wait x ln)
from ‹all_final_except s (deadlocked s)› nafe have False by simp
thus ?thesis by simp
next
case (acquire X ln l T)
from t''t Red ‹thr s t'' = ⌊(X, ln)⌋› s'
have es't'': "thr s' t'' = ⌊(X, ln)⌋"
by(cases s)(auto dest: redT_ts_Some_inv)
moreover
from ‹T ∈ deadlocked s ∨ final_thread s T›
have "T ≠ t"
proof(rule disjE)
assume "T ∈ deadlocked s"
with Red show ?thesis by(auto dest: red_no_deadlock)
next
assume "final_thread s T"
with Red show ?thesis
by(auto dest!: final_no_redT simp add: final_thread_def)
qed
with s' tst Red ‹has_lock (locks s $ l) T› have "has_lock (locks s' $ l) T"
by -(cases s, auto dest: redT_has_lock_inv[THEN iffD2])
moreover
from s' ‹T ≠ t› have wset: "wset s T = None ⟹ wset s' T = None"
by(auto intro: redT_updWs_None_implies_None)
{ fix x
assume "thr s T = ⌊(x, no_wait_locks)⌋"
with ‹T ≠ t› Red s' aok tst have "thr s' T = ⌊(x, no_wait_locks)⌋"
by(auto intro: redT_updTs_Some) }
moreover
hence "final_thread s T ⟹ final_thread s' T"
by(auto simp add: final_thread_def intro: wset)
moreover from ‹¬ waiting (wset s t'')› s' t''t
have "¬ waiting (wset s' t'')"
by(auto simp add: redT_updWs_None_implies_None redT_updWs_PostWS_imp_PostWS not_waiting_iff)
ultimately have ?Acquire
using ‹0 < ln $ l› ‹t'' ≠ T› ‹T ∈ deadlocked s ∨ final_thread s T› by(auto)
thus ?thesis by simp
qed
qed
next
case (redT_acquire x n ln)
hence [simp]: "ta = (K$ [], [], [], [], [], convert_RA ln)"
and s': "s' = (acquire_all (locks s) t ln, (thr s(t ↦ (x, no_wait_locks)), shr s), wset s, interrupts s)"
and tst: "thr s t = ⌊(x, ln)⌋"
and wst: "¬ waiting (wset s t)" by auto
from t'dead show ?thesis
proof(coinduct)
case (deadlocked t'')
note t''dead = this
with Red have t''t: "t'' ≠ t"
by(auto dest: red_no_deadlock)
from t''dead show ?case
proof(cases rule: deadlocked_elims)
case (lock X)
note clnml = ‹⋀LT. t'' ⊢ ⟨X, shr s⟩ LT ≀ ⟹ ∃lt ∈ LT. must_wait s t'' lt (deadlocked s ∪ final_threads s)›
note tst'' = ‹thr s t'' = ⌊(X, no_wait_locks)⌋›
with s' t''t have ts't'': "thr s' t'' = ⌊(X, no_wait_locks)⌋" by simp
moreover
{ fix LT
assume "t'' ⊢ ⟨X, shr s'⟩ LT ≀"
hence "t'' ⊢ ⟨X, shr s⟩ LT ≀" using s' by simp
then obtain lt where lt: "lt ∈ LT" and hlnft: "must_wait s t'' lt (deadlocked s ∪ final_threads s)"
by(blast dest: clnml)
from hlnft have "must_wait s' t'' lt (deadlocked s ∪ deadlocked s' ∪ final_threads s')"
proof(cases rule: must_wait_elims)
case (lock l' T)
from ‹has_lock (locks s $ l') T› s'
have "has_lock (locks s' $ l') T"
by(auto intro: has_lock_has_lock_acquire_locks)
moreover note ‹T ≠ t''›
moreover from ‹T ∈ deadlocked s ∪ final_threads s›
have "T ∈ deadlocked s ∪ deadlocked s' ∪ final_threads s'" using subset by blast
ultimately show ?thesis unfolding ‹lt = Inl l'› ..
next
case (join T)
from ‹not_final_thread s T› have "thr s T ≠ None"
by(auto simp add: not_final_thread_iff)
moreover
from ‹T ∈ deadlocked s ∪ final_threads s›
have "T ≠ t"
proof
assume "T ∈ deadlocked s"
with Red show ?thesis by(auto dest: red_no_deadlock)
next
assume "T ∈ final_threads s"
with ‹0 < ln $ n› tst show ?thesis
by(auto simp add: final_thread_def)
qed
ultimately have "not_final_thread s' T" using ‹not_final_thread s T› s'
by(auto simp add: not_final_thread_iff)
moreover from ‹T ∈ deadlocked s ∪ final_threads s›
have "T ∈ deadlocked s ∪ deadlocked s' ∪ final_threads s'" using subset by blast
ultimately show ?thesis unfolding ‹lt = Inr (Inl T)› ..
next
case (interrupt T)
from tst wst ‹0 < ln $ n› have "not_final_thread s t"
by(auto simp add: waiting_def not_final_thread_iff)
with ‹all_final_except s (deadlocked s ∪ final_threads s)›
have "t ∈ deadlocked s ∪ final_threads s" by(rule all_final_exceptD)
moreover have "t ∉ deadlocked s" using Red by(blast dest: red_no_deadlock)
moreover have "¬ final_thread s t" using tst ‹0 < ln $ n› by(auto simp add: final_thread_def)
ultimately have False by blast
thus ?thesis ..
qed
with lt have "∃lt∈LT. must_wait s' t'' lt (deadlocked s ∪ deadlocked s' ∪ final_threads s')" by blast }
moreover from ‹wset s t'' = None› s' have "wset s' t'' = None" by simp
ultimately show ?thesis using ‹thr s t'' = ⌊(X, no_wait_locks)⌋› ‹t'' ⊢ ⟨X, shr s⟩ ≀› s' by fastforce
next
case (wait X LN)
have "all_final_except s' (deadlocked s)"
proof(rule all_final_exceptI)
fix T
assume "not_final_thread s' T"
hence "not_final_thread s T" using wst tst s'
by(auto simp add: not_final_thread_iff split: if_split_asm)
with ‹all_final_except s (deadlocked s)› ‹thr s t = ⌊(x, ln)⌋›
show "T ∈ deadlocked s" by-(erule all_final_exceptD)
qed
hence "all_final_except s' (deadlocked s ∪ deadlocked s')"
by(rule all_final_except_mono') blast
with t''t ‹thr s t'' = ⌊(X, LN)⌋› ‹waiting (wset s t'')› s'
have ?Wait by simp
thus ?thesis by simp
next
case (acquire X LN l T)
from ‹thr s t'' = ⌊(X, LN)⌋› t''t s'
have "thr s' t'' = ⌊(X, LN)⌋" by(simp)
moreover from ‹T ∈ deadlocked s ∨ final_thread s T› s' tst
have "T ∈ deadlocked s ∨ final_thread s' T"
by(clarsimp simp add: final_thread_def)
moreover from ‹has_lock (locks s $ l) T› s'
have "has_lock (locks s' $ l) T"
by(auto intro: has_lock_has_lock_acquire_locks)
moreover have "¬ waiting (wset s' t'')" using ‹¬ waiting (wset s t'')› s' by simp
ultimately show ?thesis using ‹0 < LN $ l› ‹t'' ≠ T› by blast
qed
qed
qed
qed
corollary RedT_deadlocked_subset:
assumes wfs: "s ∈ wf_state"
and Red: "s -▹ttas→* s'"
shows "deadlocked s ⊆ deadlocked s'"
using Red
apply(induct rule: RedT_induct')
apply(unfold RedT_def)
apply(blast dest: invariant3p_rtrancl3p[OF invariant3p_wf_state _ wfs] redT_deadlocked_subset)+
done
end
end
Theory FWProgress
section ‹Progress theorem for the multithreaded semantics›
theory FWProgress
imports
FWDeadlock
begin
locale progress = multithreaded final r convert_RA
for final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics" ("_ ⊢ _ -_→ _" [50,0,0,50] 80)
and convert_RA :: "'l released_locks ⇒ 'o list"
+
fixes wf_state :: "('l,'t,'x,'m,'w) state set"
assumes wf_stateD: "s ∈ wf_state ⟹ lock_thread_ok (locks s) (thr s) ∧ wset_final_ok (wset s) (thr s)"
and wf_red:
"⟦ s ∈ wf_state; thr s t = ⌊(x, no_wait_locks)⌋;
t ⊢ (x, shr s) -ta→ (x', m'); ¬ waiting (wset s t) ⟧
⟹ ∃ta' x' m'. t ⊢ (x, shr s) -ta'→ (x', m') ∧ (actions_ok s t ta' ∨ actions_ok' s t ta' ∧ actions_subset ta' ta)"
and red_wait_set_not_final:
"⟦ s ∈ wf_state; thr s t = ⌊(x, no_wait_locks)⌋;
t ⊢ (x, shr s) -ta→ (x', m'); ¬ waiting (wset s t); Suspend w ∈ set ⦃ta⦄⇘w⇙ ⟧
⟹ ¬ final x'"
and wf_progress:
"⟦ s ∈ wf_state; thr s t = ⌊(x, no_wait_locks)⌋; ¬ final x ⟧
⟹ ∃ta x' m'. t ⊢ ⟨x, shr s⟩ -ta→ ⟨x', m'⟩"
and ta_Wakeup_no_join_no_lock_no_interrupt:
"⟦ s ∈ wf_state; thr s t = ⌊(x, no_wait_locks)⌋; t ⊢ xm -ta→ xm'; Notified ∈ set ⦃ta⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta⦄⇘w⇙ ⟧
⟹ collect_waits ta = {}"
and ta_satisfiable:
"⟦ s ∈ wf_state; thr s t = ⌊(x, no_wait_locks)⌋; t ⊢ ⟨x, shr s⟩ -ta→ ⟨x', m'⟩ ⟧
⟹ ∃s'. actions_ok s' t ta"
begin
lemma wf_redE:
assumes "s ∈ wf_state" "thr s t = ⌊(x, no_wait_locks)⌋"
and "t ⊢ ⟨x, shr s⟩ -ta→ ⟨x'', m''⟩" "¬ waiting (wset s t)"
obtains ta' x' m'
where "t ⊢ ⟨x, shr s⟩ -ta'→ ⟨x', m'⟩" "actions_ok' s t ta'" "actions_subset ta' ta"
| ta' x' m' where "t ⊢ ⟨x, shr s⟩ -ta'→ ⟨x', m'⟩" "actions_ok s t ta'"
using wf_red[OF assms] by blast
lemma wf_progressE:
assumes "s ∈ wf_state"
and "thr s t = ⌊(x, no_wait_locks)⌋" "¬ final x"
obtains ta x' m' where "t ⊢ ⟨x, shr s⟩ -ta→ ⟨x', m'⟩"
using assms
by(blast dest: wf_progress)
lemma wf_progress_satisfiable:
"⟦ s ∈ wf_state; thr s t = ⌊(x, no_wait_locks)⌋; ¬ final x ⟧
⟹ ∃ta x' m' s'. t ⊢ ⟨x, shr s⟩ -ta→ ⟨x', m'⟩ ∧ actions_ok s' t ta"
apply(frule (2) wf_progress)
apply(blast dest: ta_satisfiable)
done
theorem redT_progress:
assumes wfs: "s ∈ wf_state"
and ndead: "¬ deadlock s"
shows "∃t' ta' s'. s -t'▹ta'→ s'"
proof -
from wfs have lok: "lock_thread_ok (locks s) (thr s)"
and wfin: "wset_final_ok (wset s) (thr s)"
by(auto dest: wf_stateD)
from ndead
have "∃t x ln l. thr s t = ⌊(x, ln)⌋ ∧
(wset s t = None ∧ ln = no_wait_locks ∧ ¬ final x ∧ (∃LT. t ⊢ ⟨x, shr s⟩ LT ≀ ∧ (∀lt ∈ LT. ¬ must_wait s t lt (dom (thr s)))) ∨
¬ waiting (wset s t) ∧ ln $ l > 0 ∧ (∀l. ln $ l > 0 ⟶ may_lock (locks s $ l) t) ∨
(∃w. ln = no_wait_locks ∧ wset s t = ⌊PostWS w⌋))"
by(rule contrapos_np)(blast intro!: all_waiting_implies_deadlock[OF lok] intro: must_syncI[OF wf_progress_satisfiable[OF wfs]])
then obtain t x ln l
where tst: "thr s t = ⌊(x, ln)⌋"
and a: "wset s t = None ∧ ln = no_wait_locks ∧ ¬ final x ∧
(∃LT. t ⊢ ⟨x, shr s⟩ LT ≀ ∧ (∀lt ∈ LT. ¬ must_wait s t lt (dom (thr s)))) ∨
¬ waiting (wset s t) ∧ ln $ l > 0 ∧ (∀l. ln $ l > 0 ⟶ may_lock (locks s $ l) t) ∨
(∃w. ln = no_wait_locks ∧ wset s t = ⌊PostWS w⌋)"
by blast
from a have cases[case_names normal acquire wakeup]:
"⋀thesis.
⟦ ⋀LT. ⟦ wset s t = None; ln = no_wait_locks; ¬ final x; t ⊢ ⟨x, shr s⟩ LT ≀;
⋀lt. lt ∈ LT ⟹ ¬ must_wait s t lt (dom (thr s)) ⟧ ⟹ thesis;
⟦ ¬ waiting (wset s t); ln $ l > 0; ⋀l. ln $ l > 0 ⟹ may_lock (locks s $ l) t ⟧ ⟹ thesis;
⋀w. ⟦ ln = no_wait_locks; wset s t = ⌊PostWS w⌋ ⟧ ⟹ thesis ⟧ ⟹ thesis"
by auto
show ?thesis
proof(cases rule: cases)
case (normal LT)
note [simp] = ‹ln = no_wait_locks›
and nfine' = ‹¬ final x›
and cl' = ‹t ⊢ ⟨x, shr s⟩ LT ≀›
and mw = ‹⋀lt. lt∈LT ⟹ ¬ must_wait s t lt (dom (thr s))›
from tst nfine' obtain x'' m'' ta'
where red: "t ⊢ ⟨x, shr s⟩ -ta'→ ⟨x'', m''⟩"
by(auto intro: wf_progressE[OF wfs])
from cl'
have "∃ta''' x''' m'''. t ⊢ ⟨x, shr s⟩ -ta'''→ ⟨x''', m'''⟩ ∧
LT = collect_waits ta'''"
by (fastforce elim!: can_syncE)
then obtain ta''' x''' m'''
where red'': "t ⊢ ⟨x, shr s⟩ -ta'''→ ⟨x''', m'''⟩"
and L: "LT = collect_waits ta'''"
by blast
from ‹wset s t = None› have "¬ waiting (wset s t)" by(simp add: not_waiting_iff)
with tst obtain ta'' x'' m''
where red': "t ⊢ ⟨x, shr s⟩ -ta''→ ⟨x'', m''⟩"
and aok': "actions_ok s t ta'' ∨ actions_ok' s t ta'' ∧ actions_subset ta'' ta'''"
by -(rule wf_redE[OF wfs _ red''], auto)
from aok' have "actions_ok s t ta''"
proof
assume "actions_ok' s t ta'' ∧ actions_subset ta'' ta'''"
hence aok': "actions_ok' s t ta''" and aos: "actions_subset ta'' ta'''" by simp_all
{ fix l
assume "Inl l ∈ LT"
{ fix t'
assume "t ≠ t'"
have "¬ has_lock (locks s $ l) t'"
proof
assume "has_lock (locks s $ l) t'"
moreover with lok have "thr s t' ≠ None" by(auto dest: lock_thread_okD)
ultimately have "must_wait s t (Inl l) (dom (thr s))" using ‹t ≠ t'› by(auto)
moreover from ‹Inl l ∈ LT› have "¬ must_wait s t (Inl l) (dom (thr s))" by(rule mw)
ultimately show False by contradiction
qed }
hence "may_lock (locks s $ l) t"
by-(rule classical, auto simp add: not_may_lock_conv) }
note mayl = this
{ fix t'
assume t'LT: "Inr (Inl t') ∈ LT"
hence "¬ not_final_thread s t' ∧ t' ≠ t"
proof(cases "t' = t")
case False with t'LT mw L show ?thesis by(fastforce)
next
case True with tst mw[OF t'LT] nfine' L have False
by(auto intro!: must_wait.intros simp add: not_final_thread_iff)
thus ?thesis ..
qed }
note mayj = this
{ fix t'
assume t': "Inr (Inr t') ∈ LT"
from t' have "¬ must_wait s t (Inr (Inr t')) (dom (thr s))" by(rule mw)
hence "t' ∈ interrupts s"
by(rule contrapos_np)(fastforce intro: all_final_exceptI simp add: not_final_thread_iff) }
note interrupt = this
from aos L mayl
have "⋀l. l ∈ collect_locks' ⦃ta''⦄⇘l⇙ ⟹ may_lock (locks s $ l) t" by auto
with aok' have "lock_ok_las (locks s) t ⦃ta''⦄⇘l⇙" by(auto intro: lock_ok_las'_into_lock_on_las)
moreover
from mayj aos L
have "cond_action_oks s t ⦃ta''⦄⇘c⇙"
by(fastforce intro: may_join_cond_action_oks)
moreover
from ta_satisfiable[OF wfs tst[simplified] red']
obtain is' where "interrupt_actions_ok is' ⦃ta''⦄⇘i⇙" by auto
with interrupt aos aok' L have "interrupt_actions_ok (interrupts s) ⦃ta''⦄⇘i⇙"
by(auto 5 2 intro: interrupt_actions_ok'_collect_interrupts_imp_interrupt_actions_ok)
ultimately show "actions_ok s t ta''" using aok' by auto
qed
moreover obtain ws'' where "redT_updWs t (wset s) ⦃ta''⦄⇘w⇙ ws''"
using redT_updWs_total[of t "wset s" "⦃ta''⦄⇘w⇙"] ..
then obtain s' where "redT_upd s t ta'' x'' m'' s'" by fastforce
ultimately have "s -t▹ta''→ s'"
using red' tst ‹wset s t = None› by(auto intro: redT_normal)
thus ?thesis by blast
next
case acquire
hence "may_acquire_all (locks s) t ln" by(auto)
with tst ‹¬ waiting (wset s t)› ‹0 < ln $ l›
show ?thesis by(fastforce intro: redT_acquire)
next
case (wakeup w)
from ‹wset s t = ⌊PostWS w⌋›
have "¬ waiting (wset s t)" by(simp add: not_waiting_iff)
from tst wakeup have tst: "thr s t = ⌊(x, no_wait_locks)⌋" by simp
from wakeup tst wfin have "¬ final x" by(auto dest: wset_final_okD)
from wf_progress[OF wfs tst this]
obtain ta x' m' where red: "t ⊢ ⟨x, shr s⟩ -ta→ ⟨x', m'⟩" by auto
from wf_red[OF wfs tst red ‹¬ waiting (wset s t)›]
obtain ta' x'' m''
where red': "t ⊢ ⟨x, shr s⟩ -ta'→ ⟨x'', m''⟩"
and aok': "actions_ok s t ta' ∨ actions_ok' s t ta' ∧ actions_subset ta' ta" by blast
from aok' have "actions_ok s t ta'"
proof
assume "actions_ok' s t ta' ∧ actions_subset ta' ta"
hence aok': "actions_ok' s t ta'"
and subset: "actions_subset ta' ta" by simp_all
from wakeup aok' have "Notified ∈ set ⦃ta'⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta'⦄⇘w⇙"
by(auto simp add: wset_actions_ok_def split: if_split_asm)
from ta_Wakeup_no_join_no_lock_no_interrupt[OF wfs tst red' this]
have no_join: "collect_cond_actions ⦃ta'⦄⇘c⇙ = {}"
and no_lock: "collect_locks ⦃ta'⦄⇘l⇙ = {}"
and no_interrupt: "collect_interrupts ⦃ta'⦄⇘i⇙ = {}" by auto
from no_lock have no_lock': "collect_locks' ⦃ta'⦄⇘l⇙ = {}"
using collect_locks'_subset_collect_locks[of "⦃ta'⦄⇘l⇙"] by auto
from aok' have "lock_ok_las' (locks s) t ⦃ta'⦄⇘l⇙" by auto
hence "lock_ok_las (locks s) t ⦃ta'⦄⇘l⇙"
by(rule lock_ok_las'_into_lock_on_las)(simp add: no_lock')
moreover from subset aok' no_join have "cond_action_oks s t ⦃ta'⦄⇘c⇙"
by(auto intro: may_join_cond_action_oks)
moreover from ta_satisfiable[OF wfs tst[simplified] red']
obtain is' where "interrupt_actions_ok is' ⦃ta'⦄⇘i⇙" by auto
with aok' no_interrupt have "interrupt_actions_ok (interrupts s) ⦃ta'⦄⇘i⇙"
by(auto intro: interrupt_actions_ok'_collect_interrupts_imp_interrupt_actions_ok)
ultimately show "actions_ok s t ta'" using aok' by auto
qed
moreover obtain ws'' where "redT_updWs t (wset s) ⦃ta'⦄⇘w⇙ ws''"
using redT_updWs_total[of t "wset s" "⦃ta'⦄⇘w⇙"] ..
then obtain s' where "redT_upd s t ta' x'' m'' s'" by fastforce
ultimately have "s -t▹ta'→ s'" using tst red' wakeup
by(auto intro: redT_normal)
thus ?thesis by blast
qed
qed
end
end
Theory FWLifting
section ‹Lifting of thread-local properties to the multithreaded case›
theory FWLifting
imports
FWWellform
begin
text‹Lifting for properties that only involve thread-local state information and the shared memory.›
definition
ts_ok :: "('t ⇒ 'x ⇒ 'm ⇒ bool) ⇒ ('l, 't,'x) thread_info ⇒ 'm ⇒ bool"
where
"⋀ln. ts_ok P ts m ≡ ∀t. case (ts t) of None ⇒ True | ⌊(x, ln)⌋ ⇒ P t x m"
lemma ts_okI:
"⟦ ⋀t x ln. ts t = ⌊(x, ln)⌋ ⟹ P t x m ⟧ ⟹ ts_ok P ts m"
by(auto simp add: ts_ok_def)
lemma ts_okE:
"⟦ ts_ok P ts m; ⟦ ⋀t x ln. ts t = ⌊(x, ln)⌋ ⟹ P t x m ⟧ ⟹ Q ⟧ ⟹ Q"
by(auto simp add: ts_ok_def)
lemma ts_okD:
"⋀ln. ⟦ ts_ok P ts m; ts t = ⌊(x, ln)⌋ ⟧ ⟹ P t x m"
by(auto simp add: ts_ok_def)
lemma ts_ok_True [simp]:
"ts_ok (λt m x. True) ts m"
by(auto intro: ts_okI)
lemma ts_ok_conj:
"ts_ok (λt x m. P t x m ∧ Q t x m) = (λts m. ts_ok P ts m ∧ ts_ok Q ts m)"
by(auto intro: ts_okI intro!: ext dest: ts_okD)
lemma ts_ok_mono:
"⟦ ts_ok P ts m; ⋀t x. P t x m ⟹ Q t x m ⟧ ⟹ ts_ok Q ts m"
by(auto intro!: ts_okI dest: ts_okD)
text‹Lifting for properites, that also require additional data that does not change during execution›
definition
ts_inv :: "('i ⇒ 't ⇒ 'x ⇒ 'm ⇒ bool) ⇒ ('t ⇀ 'i) ⇒ ('l,'t,'x) thread_info ⇒ 'm ⇒ bool"
where
"⋀ln. ts_inv P I ts m ≡ ∀t. case (ts t) of None ⇒ True | ⌊(x, ln)⌋ ⇒ ∃i. I t = ⌊i⌋ ∧ P i t x m"
lemma ts_invI:
"⟦ ⋀t x ln. ts t = ⌊(x, ln)⌋ ⟹ ∃i. I t = ⌊i⌋ ∧ P i t x m ⟧ ⟹ ts_inv P I ts m"
by(simp add: ts_inv_def)
lemma ts_invE:
"⟦ ts_inv P I ts m; ∀t x ln. ts t = ⌊(x, ln)⌋ ⟶ (∃i. I t = ⌊i⌋ ∧ P i t x m) ⟹ R ⟧ ⟹ R"
by(auto simp add: ts_inv_def)
lemma ts_invD:
"⋀ln. ⟦ ts_inv P I ts m; ts t = ⌊(x, ln)⌋ ⟧ ⟹ ∃i. I t = ⌊i⌋ ∧ P i t x m"
by(auto simp add: ts_inv_def)
text ‹Wellformedness properties for lifting›
definition
ts_inv_ok :: "('l,'t,'x) thread_info ⇒ ('t ⇀ 'i) ⇒ bool"
where
"ts_inv_ok ts I ≡ ∀t. ts t = None ⟷ I t = None"
lemma ts_inv_okI:
"(⋀t. ts t = None ⟷ I t = None) ⟹ ts_inv_ok ts I"
by(clarsimp simp add: ts_inv_ok_def)
lemma ts_inv_okI2:
"(⋀t. (∃v. ts t = ⌊v⌋) ⟷ (∃v. I t = ⌊v⌋)) ⟹ ts_inv_ok ts I"
by(force simp add: ts_inv_ok_def)
lemma ts_inv_okE:
"⟦ ts_inv_ok ts I; ∀t. ts t = None ⟷ I t = None ⟹ P ⟧ ⟹ P"
by(force simp add: ts_inv_ok_def)
lemma ts_inv_okE2:
"⟦ ts_inv_ok ts I; ∀t. (∃v. ts t = ⌊v⌋) ⟷ (∃v. I t = ⌊v⌋) ⟹ P ⟧ ⟹ P"
by(force simp add: ts_inv_ok_def)
lemma ts_inv_okD:
"ts_inv_ok ts I ⟹ (ts t = None) ⟷ (I t = None)"
by(erule ts_inv_okE, blast)
lemma ts_inv_okD2:
"ts_inv_ok ts I ⟹ (∃v. ts t = ⌊v⌋) ⟷ (∃v. I t = ⌊v⌋)"
by(erule ts_inv_okE2, blast)
lemma ts_inv_ok_conv_dom_eq:
"ts_inv_ok ts I ⟷ (dom ts = dom I)"
proof -
have "ts_inv_ok ts I ⟷ (∀t. ts t = None ⟷ I t = None)"
unfolding ts_inv_ok_def by blast
also have "… ⟷ (∀t. t ∈ - dom ts ⟷ t ∈ - dom I)" by(force)
also have "… ⟷ dom ts = dom I" by auto
finally show ?thesis .
qed
lemma ts_inv_ok_upd_ts:
"⟦ ts t = ⌊x⌋; ts_inv_ok ts I ⟧ ⟹ ts_inv_ok (ts(t ↦ x')) I"
by(auto dest!: ts_inv_okD intro!: ts_inv_okI split: if_splits)
lemma ts_inv_upd_map_option:
assumes "ts_inv P I ts m"
and "⋀x ln. ts t = ⌊(x, ln)⌋ ⟹ P (the (I t)) t (fst (f (x, ln))) m"
shows "ts_inv P I (ts(t := (map_option f (ts t)))) m"
using assms
by(fastforce intro!: ts_invI split: if_split_asm dest: ts_invD)
fun upd_inv :: "('t ⇀ 'i) ⇒ ('i ⇒ 't ⇒ 'x ⇒ 'm ⇒ bool) ⇒ ('t,'x,'m) new_thread_action ⇒ ('t ⇀ 'i)"
where
"upd_inv I P (NewThread t x m) = I(t ↦ SOME i. P i t x m)"
| "upd_inv I P _ = I"
fun upd_invs :: "('t ⇀ 'i) ⇒ ('i ⇒ 't ⇒ 'x ⇒ 'm ⇒ bool) ⇒ ('t,'x,'m) new_thread_action list ⇒ ('t ⇀ 'i)"
where
"upd_invs I P [] = I"
| "upd_invs I P (ta#tas) = upd_invs (upd_inv I P ta) P tas"
lemma upd_invs_append [simp]:
"upd_invs I P (xs @ ys) = upd_invs (upd_invs I P xs) P ys"
by(induct xs arbitrary: I)(auto)
lemma ts_inv_ok_upd_inv':
"ts_inv_ok ts I ⟹ ts_inv_ok (redT_updT' ts ta) (upd_inv I P ta)"
by(cases ta)(auto intro!: ts_inv_okI elim: ts_inv_okD del: iffI)
lemma ts_inv_ok_upd_invs':
"ts_inv_ok ts I ⟹ ts_inv_ok (redT_updTs' ts tas) (upd_invs I P tas)"
proof(induct tas arbitrary: ts I)
case Nil thus ?case by simp
next
case (Cons TA TAS TS I)
note IH = ‹⋀ts I. ts_inv_ok ts I ⟹ ts_inv_ok (redT_updTs' ts TAS) (upd_invs I P TAS)›
note esok = ‹ts_inv_ok TS I›
from esok have "ts_inv_ok (redT_updT' TS TA) (upd_inv I P TA)"
by -(rule ts_inv_ok_upd_inv')
hence "ts_inv_ok (redT_updTs' (redT_updT' TS TA) TAS) (upd_invs (upd_inv I P TA) P TAS)"
by (rule IH)
thus ?case by simp
qed
lemma ts_inv_ok_upd_inv:
"ts_inv_ok ts I ⟹ ts_inv_ok (redT_updT ts ta) (upd_inv I P ta)"
apply(cases ta)
apply(auto intro!: ts_inv_okI elim: ts_inv_okD del: iffI)
done
lemma ts_inv_ok_upd_invs:
"ts_inv_ok ts I ⟹ ts_inv_ok (redT_updTs ts tas) (upd_invs I P tas)"
proof(induct tas arbitrary: ts I)
case Nil thus ?case by simp
next
case (Cons TA TAS TS I)
note IH = ‹⋀ts I. ts_inv_ok ts I ⟹ ts_inv_ok (redT_updTs ts TAS) (upd_invs I P TAS)›
note esok = ‹ts_inv_ok TS I›
from esok have "ts_inv_ok (redT_updT TS TA) (upd_inv I P TA)"
by -(rule ts_inv_ok_upd_inv)
hence "ts_inv_ok (redT_updTs (redT_updT TS TA) TAS) (upd_invs (upd_inv I P TA) P TAS)"
by (rule IH)
thus ?case by simp
qed
lemma ts_inv_ok_inv_ext_upd_inv:
"⟦ ts_inv_ok ts I; thread_ok ts ta ⟧ ⟹ I ⊆⇩m upd_inv I P ta"
by(cases ta)(auto intro!: map_le_same_upd dest: ts_inv_okD)
lemma ts_inv_ok_inv_ext_upd_invs:
"⟦ ts_inv_ok ts I; thread_oks ts tas⟧
⟹ I ⊆⇩m upd_invs I P tas"
proof(induct tas arbitrary: ts I)
case Nil thus ?case by simp
next
case (Cons TA TAS TS I)
note IH = ‹⋀ts I. ⟦ ts_inv_ok ts I; thread_oks ts TAS⟧ ⟹ I ⊆⇩m upd_invs I P TAS›
note esinv = ‹ts_inv_ok TS I›
note cct = ‹thread_oks TS (TA # TAS)›
from esinv cct have "I ⊆⇩m upd_inv I P TA"
by(auto intro: ts_inv_ok_inv_ext_upd_inv)
also from esinv cct have "ts_inv_ok (redT_updT' TS TA) (upd_inv I P TA)"
by(auto intro: ts_inv_ok_upd_inv')
with cct have "upd_inv I P TA ⊆⇩m upd_invs (upd_inv I P TA) P TAS"
by(auto intro: IH)
finally show ?case by simp
qed
lemma upd_invs_Some:
"⟦ thread_oks ts tas; I t = ⌊i⌋; ts t = ⌊x⌋ ⟧ ⟹ upd_invs I Q tas t = ⌊i⌋"
proof(induct tas arbitrary: ts I)
case Nil thus ?case by simp
next
case (Cons TA TAS TS I)
note IH = ‹⋀ts I. ⟦thread_oks ts TAS; I t = ⌊i⌋; ts t = ⌊x⌋⟧ ⟹ upd_invs I Q TAS t = ⌊i⌋›
note cct = ‹thread_oks TS (TA # TAS)›
note it = ‹I t = ⌊i⌋›
note est = ‹TS t = ⌊x⌋›
from cct have cctta: "thread_ok TS TA"
and ccttas: "thread_oks (redT_updT' TS TA) TAS" by auto
from cctta it est have "upd_inv I Q TA t = ⌊i⌋"
by(cases TA, auto)
moreover
have "redT_updT' TS TA t = ⌊x⌋" using cctta est
by - (rule redT_updT'_Some)
ultimately have "upd_invs (upd_inv I Q TA) Q TAS t = ⌊i⌋" using ccttas
by -(erule IH)
thus ?case by simp
qed
lemma upd_inv_Some_eq:
"⟦ thread_ok ts ta; ts t = ⌊x⌋ ⟧ ⟹ upd_inv I Q ta t = I t"
by(cases ta, auto)
lemma upd_invs_Some_eq: "⟦ thread_oks ts tas; ts t = ⌊x⌋ ⟧ ⟹ upd_invs I Q tas t = I t"
proof(induct tas arbitrary: ts I)
case Nil thus ?case by simp
next
case (Cons TA TAS TS I)
note IH = ‹⋀ts I. ⟦thread_oks ts TAS; ts t = ⌊x⌋⟧ ⟹ upd_invs I Q TAS t = I t›
note cct = ‹thread_oks TS (TA # TAS)›
note est = ‹TS t = ⌊x⌋›
from cct est have "upd_invs (upd_inv I Q TA) Q TAS t = upd_inv I Q TA t"
apply(clarsimp)
apply(erule IH)
by(rule redT_updT'_Some)
also from cct est have "… = I t"
by(auto elim: upd_inv_Some_eq)
finally show ?case by simp
qed
lemma SOME_new_thread_upd_invs:
assumes Qsome: "Q (SOME i. Q i t x m) t x m"
and nt: "NewThread t x m ∈ set tas"
and cct: "thread_oks ts tas"
shows "∃i. upd_invs I Q tas t = ⌊i⌋ ∧ Q i t x m"
proof(rule exI[where x="SOME i. Q i t x m"])
from nt cct have "upd_invs I Q tas t = ⌊SOME i. Q i t x m⌋"
proof(induct tas arbitrary: ts I)
case Nil thus ?case by simp
next
case (Cons TA TAS TS I)
note IH = ‹⋀ts I. ⟦ NewThread t x m ∈ set TAS; thread_oks ts TAS ⟧ ⟹ upd_invs I Q TAS t = ⌊SOME i. Q i t x m⌋›
note nt = ‹NewThread t x m ∈ set (TA # TAS)›
note cct = ‹thread_oks TS (TA # TAS)›
{ assume nt': "NewThread t x m ∈ set TAS"
from cct have ?case
apply(clarsimp)
by(rule IH[OF nt']) }
moreover
{ assume ta: "TA = NewThread t x m"
with cct have rup: "redT_updT' TS TA t = ⌊(undefined, no_wait_locks)⌋"
by(simp)
from cct have cctta: "thread_oks (redT_updT' TS TA) TAS" by simp
from ta have "upd_inv I Q TA t = ⌊SOME i. Q i t x m⌋"
by(simp)
hence ?case
by(clarsimp simp add: upd_invs_Some_eq[OF cctta, OF rup]) }
ultimately show ?case using nt by auto
qed
with Qsome show "upd_invs I Q tas t = ⌊SOME i. Q i t x m⌋ ∧ Q (SOME i. Q i t x m) t x m"
by(simp)
qed
lemma ts_ok_into_ts_inv_const:
assumes "ts_ok P ts m"
obtains I where "ts_inv (λ_. P) I ts m"
proof -
from assms have "ts_inv (λ_. P) (λt. if t ∈ dom ts then Some undefined else None) ts m"
by(auto intro!: ts_invI dest: ts_okD)
thus thesis by(rule that)
qed
lemma ts_inv_const_into_ts_ok:
"ts_inv (λ_. P) I ts m ⟹ ts_ok P ts m"
by(auto intro!: ts_okI dest: ts_invD)
lemma ts_inv_into_ts_ok_Ex:
"ts_inv Q I ts m ⟹ ts_ok (λt x m. ∃i. Q i t x m) ts m"
by(rule ts_okI)(blast dest: ts_invD)
lemma ts_ok_Ex_into_ts_inv:
"ts_ok (λt x m. ∃i. Q i t x m) ts m ⟹ ∃I. ts_inv Q I ts m"
by(rule exI[where x="λt. ⌊SOME i. Q i t (fst (the (ts t))) m⌋"])(auto 4 4 dest: ts_okD intro: someI intro: ts_invI)
lemma Ex_ts_inv_conv_ts_ok:
"(∃I. ts_inv Q I ts m) ⟷ (ts_ok (λt x m. ∃i. Q i t x m) ts m)"
by(auto dest: ts_inv_into_ts_ok_Ex ts_ok_Ex_into_ts_inv)
end
Theory LTS
section ‹Labelled transition systems›
theory LTS
imports
"../Basic/Auxiliary"
Coinductive.TLList
begin
no_notation floor ("⌊_⌋")
lemma rel_option_mono:
"⟦ rel_option R x y; ⋀x y. R x y ⟹ R' x y ⟧ ⟹ rel_option R' x y"
by(cases x)(case_tac [!] y, auto)
lemma nth_concat_conv:
"n < length (concat xss)
⟹ ∃m n'. concat xss ! n = (xss ! m) ! n' ∧ n' < length (xss ! m) ∧
m < length xss ∧ n = (∑i<m. length (xss ! i)) + n'"
using lnth_lconcat_conv[of n "llist_of (map llist_of xss)"]
sum_hom[where f = enat and h = "λi. length (xss ! i)"]
by(clarsimp simp add: lconcat_llist_of zero_enat_def[symmetric]) blast
definition flip :: "('a ⇒ 'b ⇒ 'c) ⇒ 'b ⇒ 'a ⇒ 'c"
where "flip f = (λb a. f a b)"
text ‹Create a dynamic list ‹flip_simps› of theorems for flip›
ML ‹
structure FlipSimpRules = Named_Thms
(
val name = @{binding flip_simps}
val description = "Simplification rules for flip in bisimulations"
)
›
setup ‹FlipSimpRules.setup›
lemma flip_conv [flip_simps]: "flip f b a = f a b"
by(simp add: flip_def)
lemma flip_flip [flip_simps, simp]: "flip (flip f) = f"
by(simp add: flip_def)
lemma list_all2_flip [flip_simps]: "list_all2 (flip P) xs ys = list_all2 P ys xs"
unfolding flip_def list_all2_conv_all_nth by auto
lemma llist_all2_flip [flip_simps]: "llist_all2 (flip P) xs ys = llist_all2 P ys xs"
unfolding flip_def llist_all2_conv_all_lnth by auto
lemma rtranclp_flipD:
assumes "(flip r)^** x y"
shows "r^** y x"
using assms
by(induct rule: rtranclp_induct)(auto intro: rtranclp.rtrancl_into_rtrancl simp add: flip_conv)
lemma rtranclp_flip [flip_simps]:
"(flip r)^** = flip r^**"
by(auto intro!: ext simp add: flip_conv intro: rtranclp_flipD)
lemma rel_prod_flip [flip_simps]:
"rel_prod (flip R) (flip S) = flip (rel_prod R S)"
by(auto intro!: ext simp add: flip_def)
lemma rel_option_flip [flip_simps]:
"rel_option (flip R) = flip (rel_option R)"
by(simp add: fun_eq_iff rel_option_iff flip_def)
lemma tllist_all2_flip [flip_simps]:
"tllist_all2 (flip P) (flip Q) xs ys ⟷ tllist_all2 P Q ys xs"
proof
assume "tllist_all2 (flip P) (flip Q) xs ys"
thus "tllist_all2 P Q ys xs"
by(coinduct rule: tllist_all2_coinduct)(auto dest: tllist_all2_is_TNilD tllist_all2_tfinite2_terminalD tllist_all2_thdD intro: tllist_all2_ttlI simp add: flip_def)
next
assume "tllist_all2 P Q ys xs"
thus "tllist_all2 (flip P) (flip Q) xs ys"
by(coinduct rule: tllist_all2_coinduct)(auto dest: tllist_all2_is_TNilD tllist_all2_tfinite2_terminalD tllist_all2_thdD intro: tllist_all2_ttlI simp add: flip_def)
qed
subsection ‹Labelled transition systems›
type_synonym ('a, 'b) trsys = "'a ⇒ 'b ⇒ 'a ⇒ bool"
locale trsys =
fixes trsys :: "('s, 'tl) trsys" ("_/ -_→/ _" [50, 0, 50] 60)
begin
abbreviation Trsys :: "('s, 'tl list) trsys" ("_/ -_→*/ _" [50,0,50] 60)
where "⋀tl. s -tl→* s' ≡ rtrancl3p trsys s tl s'"
coinductive inf_step :: "'s ⇒ 'tl llist ⇒ bool" ("_ -_→* ∞" [50, 0] 80)
where inf_stepI: "⟦ trsys a b a'; a' -bs→* ∞ ⟧ ⟹ a -LCons b bs→* ∞"
coinductive inf_step_table :: "'s ⇒ ('s × 'tl × 's) llist ⇒ bool" ("_ -_→*t ∞" [50, 0] 80)
where
inf_step_tableI:
"⋀tl. ⟦ trsys s tl s'; s' -stls→*t ∞ ⟧
⟹ s -LCons (s, tl, s') stls→*t ∞"
definition inf_step2inf_step_table :: "'s ⇒ 'tl llist ⇒ ('s × 'tl × 's) llist"
where
"inf_step2inf_step_table s tls =
unfold_llist
(λ(s, tls). lnull tls)
(λ(s, tls). (s, lhd tls, SOME s'. trsys s (lhd tls) s' ∧ s' -ltl tls→* ∞))
(λ(s, tls). (SOME s'. trsys s (lhd tls) s' ∧ s' -ltl tls→* ∞, ltl tls))
(s, tls)"
coinductive Rtrancl3p :: "'s ⇒ ('tl, 's) tllist ⇒ bool"
where
Rtrancl3p_stop: "(⋀tl s'. ¬ s -tl→ s') ⟹ Rtrancl3p s (TNil s)"
| Rtrancl3p_into_Rtrancl3p: "⋀tl. ⟦ s -tl→ s'; Rtrancl3p s' tlss ⟧ ⟹ Rtrancl3p s (TCons tl tlss)"
inductive_simps Rtrancl3p_simps:
"Rtrancl3p s (TNil s')"
"Rtrancl3p s (TCons tl' tlss)"
inductive_cases Rtrancl3p_cases:
"Rtrancl3p s (TNil s')"
"Rtrancl3p s (TCons tl' tlss)"
coinductive Runs :: "'s ⇒ 'tl llist ⇒ bool"
where
Stuck: "(⋀tl s'. ¬ s -tl→ s') ⟹ Runs s LNil"
| Step: "⋀tl. ⟦ s -tl→ s'; Runs s' tls ⟧ ⟹ Runs s (LCons tl tls)"
coinductive Runs_table :: "'s ⇒ ('s × 'tl × 's) llist ⇒ bool"
where
Stuck: "(⋀tl s'. ¬ s -tl→ s') ⟹ Runs_table s LNil"
| Step: "⋀tl. ⟦ s -tl→ s'; Runs_table s' stlss ⟧ ⟹ Runs_table s (LCons (s, tl, s') stlss)"
inductive_simps Runs_table_simps:
"Runs_table s LNil"
"Runs_table s (LCons stls stlss)"
lemma inf_step_not_finite_llist:
assumes r: "s -bs→* ∞"
shows "¬ lfinite bs"
proof
assume "lfinite bs" thus False using r
by(induct arbitrary: s rule: lfinite.induct)(auto elim: inf_step.cases)
qed
lemma inf_step2inf_step_table_LNil [simp]: "inf_step2inf_step_table s LNil = LNil"
by(simp add: inf_step2inf_step_table_def)
lemma inf_step2inf_step_table_LCons [simp]:
fixes tl shows
"inf_step2inf_step_table s (LCons tl tls) =
LCons (s, tl, SOME s'. trsys s tl s' ∧ s' -tls→* ∞)
(inf_step2inf_step_table (SOME s'. trsys s tl s' ∧ s' -tls→* ∞) tls)"
by(simp add: inf_step2inf_step_table_def)
lemma lnull_inf_step2inf_step_table [simp]:
"lnull (inf_step2inf_step_table s tls) ⟷ lnull tls"
by(simp add: inf_step2inf_step_table_def)
lemma inf_step2inf_step_table_eq_LNil:
"inf_step2inf_step_table s tls = LNil ⟷ tls = LNil"
using lnull_inf_step2inf_step_table unfolding lnull_def .
lemma lhd_inf_step2inf_step_table [simp]:
"¬ lnull tls
⟹ lhd (inf_step2inf_step_table s tls) =
(s, lhd tls, SOME s'. trsys s (lhd tls) s' ∧ s' -ltl tls→* ∞)"
by(simp add: inf_step2inf_step_table_def)
lemma ltl_inf_step2inf_step_table [simp]:
"ltl (inf_step2inf_step_table s tls) =
inf_step2inf_step_table (SOME s'. trsys s (lhd tls) s' ∧ s' -ltl tls→* ∞) (ltl tls)"
by(cases tls) simp_all
lemma lmap_inf_step2inf_step_table: "lmap (fst ∘ snd) (inf_step2inf_step_table s tls) = tls"
by(coinduction arbitrary: s tls) auto
lemma inf_step_imp_inf_step_table:
assumes "s -tls→* ∞"
shows "∃stls. s -stls→*t ∞ ∧ tls = lmap (fst ∘ snd) stls"
proof -
from assms have "s -inf_step2inf_step_table s tls→*t ∞"
proof(coinduction arbitrary: s tls)
case (inf_step_table s tls)
thus ?case
proof cases
case (inf_stepI tl s' tls')
let ?s' = "SOME s'. trsys s tl s' ∧ s' -tls'→* ∞"
have "trsys s tl ?s' ∧ ?s' -tls'→* ∞" by(rule someI)(blast intro: inf_stepI)
thus ?thesis using ‹tls = LCons tl tls'› by auto
qed
qed
moreover have "tls = lmap (fst ∘ snd) (inf_step2inf_step_table s tls)"
by(simp only: lmap_inf_step2inf_step_table)
ultimately show ?thesis by blast
qed
lemma inf_step_table_imp_inf_step:
"s-stls→*t ∞ ⟹s -lmap (fst ∘ snd) stls→* ∞"
proof(coinduction arbitrary: s stls rule: inf_step.coinduct)
case (inf_step s tls)
thus ?case by cases auto
qed
lemma Runs_table_into_Runs:
"Runs_table s stlss ⟹ Runs s (lmap (λ(s, tl, s'). tl) stlss)"
proof(coinduction arbitrary: s stlss)
case (Runs s tls)
thus ?case by (cases)auto
qed
lemma Runs_into_Runs_table:
assumes "Runs s tls"
obtains stlss
where "tls = lmap (λ(s, tl, s'). tl) stlss"
and "Runs_table s stlss"
proof -
define stlss where "stlss s tls = unfold_llist
(λ(s, tls). lnull tls)
(λ(s, tls). (s, lhd tls, SOME s'. s -lhd tls→ s' ∧ Runs s' (ltl tls)))
(λ(s, tls). (SOME s'. s -lhd tls→ s' ∧ Runs s' (ltl tls), ltl tls))
(s, tls)"
for s tls
have [simp]:
"⋀s. stlss s LNil = LNil"
"⋀s tl tls. stlss s (LCons tl tls) = LCons (s, tl, SOME s'. s -tl→ s' ∧ Runs s' tls) (stlss (SOME s'. s -tl→ s' ∧ Runs s' tls) tls)"
"⋀s tls. lnull (stlss s tls) ⟷ lnull tls"
"⋀s tls. ¬ lnull tls ⟹ lhd (stlss s tls) = (s, lhd tls, SOME s'. s -lhd tls→ s' ∧ Runs s' (ltl tls))"
"⋀s tls. ¬ lnull tls ⟹ ltl (stlss s tls) = stlss (SOME s'. s -lhd tls→ s' ∧ Runs s' (ltl tls)) (ltl tls)"
by(simp_all add: stlss_def)
from assms have "tls = lmap (λ(s, tl, s'). tl) (stlss s tls)"
proof(coinduction arbitrary: s tls)
case Eq_llist
thus ?case by cases(auto 4 3 intro: someI2)
qed
moreover
from assms have "Runs_table s (stlss s tls)"
proof(coinduction arbitrary: s tls)
case (Runs_table s stlss')
thus ?case
proof(cases)
case (Step s' tls' tl)
let ?P = "λs'. s -tl→ s' ∧ Runs s' tls'"
from ‹s -tl→ s'› ‹Runs s' tls'› have "?P s'" ..
hence "?P (Eps ?P)" by(rule someI)
with Step have ?Step by auto
thus ?thesis ..
qed simp
qed
ultimately show ?thesis by(rule that)
qed
lemma Runs_lappendE:
assumes "Runs σ (lappend tls tls')"
and "lfinite tls"
obtains σ' where "σ -list_of tls→* σ'"
and "Runs σ' tls'"
proof(atomize_elim)
from ‹lfinite tls› ‹Runs σ (lappend tls tls')›
show "∃σ'. σ -list_of tls→* σ' ∧ Runs σ' tls'"
proof(induct arbitrary: σ)
case lfinite_LNil thus ?case by(auto)
next
case (lfinite_LConsI tls tl)
from ‹Runs σ (lappend (LCons tl tls) tls')›
show ?case unfolding lappend_code
proof(cases)
case (Step σ')
from ‹Runs σ' (lappend tls tls') ⟹ ∃σ''. σ' -list_of tls→* σ'' ∧ Runs σ'' tls'› ‹Runs σ' (lappend tls tls')›
obtain σ'' where "σ' -list_of tls→* σ''" "Runs σ'' tls'" by blast
from ‹σ -tl→ σ'› ‹σ' -list_of tls→* σ''›
have "σ -tl # list_of tls→* σ''" by(rule rtrancl3p_step_converse)
with ‹lfinite tls› have "σ -list_of (LCons tl tls)→* σ''" by(simp)
with ‹Runs σ'' tls'› show ?thesis by blast
qed
qed
qed
lemma Trsys_into_Runs:
assumes "s -tls→* s'"
and "Runs s' tls'"
shows "Runs s (lappend (llist_of tls) tls')"
using assms
by(induct rule: rtrancl3p_converse_induct)(auto intro: Runs.Step)
lemma rtrancl3p_into_Rtrancl3p:
"⟦ rtrancl3p trsys a bs a'; ⋀b a''. ¬ a' -b→ a'' ⟧ ⟹ Rtrancl3p a (tllist_of_llist a' (llist_of bs))"
by(induct rule: rtrancl3p_converse_induct)(auto intro: Rtrancl3p.intros)
lemma Rtrancl3p_into_Runs:
"Rtrancl3p s tlss ⟹ Runs s (llist_of_tllist tlss)"
by(coinduction arbitrary: s tlss rule: Runs.coinduct)(auto elim: Rtrancl3p.cases)
lemma Runs_into_Rtrancl3p:
assumes "Runs s tls"
obtains tlss where "tls = llist_of_tllist tlss" "Rtrancl3p s tlss"
proof
let ?Q = "λs tls s'. s -lhd tls→ s' ∧ Runs s' (ltl tls)"
define tlss where "tlss = corec_tllist
(λ(s, tls). lnull tls) (λ(s, tls). s)
(λ(s, tls). lhd tls)
(λ_. False) undefined (λ(s, tls). (SOME s'. ?Q s tls s', ltl tls))"
have [simp]:
"tlss (s, LNil) = TNil s"
"tlss (s, LCons tl tls) = TCons tl (tlss (SOME s'. ?Q s (LCons tl tls) s', tls))"
for s tl tls by(auto simp add: tlss_def intro: tllist.expand)
show "tls = llist_of_tllist (tlss (s, tls))" using assms
by(coinduction arbitrary: s tls)(erule Runs.cases; fastforce intro: someI2)
show "Rtrancl3p s (tlss (s, tls))" using assms
by(coinduction arbitrary: s tls)(erule Runs.cases; simp; iprover intro: someI2[where Q="trsys _ _"] someI2[where Q="λs'. Runs s' _"])
qed
lemma fixes tl
assumes "Rtrancl3p s tlss" "tfinite tlss"
shows Rtrancl3p_into_Trsys: "Trsys s (list_of (llist_of_tllist tlss)) (terminal tlss)"
and terminal_Rtrancl3p_final: "¬ terminal tlss -tl→ s'"
using assms(2,1) by(induction arbitrary: s rule: tfinite_induct)(auto simp add: Rtrancl3p_simps intro: rtrancl3p_step_converse)
end
subsection ‹Labelled transition systems with internal actions›
locale τtrsys = trsys +
constrains trsys :: "('s, 'tl) trsys"
fixes τmove :: "('s, 'tl) trsys"
begin
inductive silent_move :: "'s ⇒ 's ⇒ bool" ("_ -τ→ _" [50, 50] 60)
where [intro]: "!!tl. ⟦ trsys s tl s'; τmove s tl s' ⟧ ⟹ s -τ→ s'"
declare silent_move.cases [elim]
lemma silent_move_iff: "silent_move = (λs s'. (∃tl. trsys s tl s' ∧ τmove s tl s'))"
by(auto simp add: fun_eq_iff)
abbreviation silent_moves :: "'s ⇒ 's ⇒ bool" ("_ -τ→* _" [50, 50] 60)
where "silent_moves == silent_move^**"
abbreviation silent_movet :: "'s ⇒ 's ⇒ bool" ("_ -τ→+ _" [50, 50] 60)
where "silent_movet == silent_move^++"
coinductive τdiverge :: "'s ⇒ bool" ("_ -τ→ ∞" [50] 60)
where
τdivergeI: "⟦ s -τ→ s'; s' -τ→ ∞ ⟧ ⟹ s -τ→ ∞"
coinductive τinf_step :: "'s ⇒ 'tl llist ⇒ bool" ("_ -τ-_→* ∞" [50, 0] 60)
where
τinf_step_Cons: "⋀tl. ⟦ s -τ→* s'; s' -tl→ s''; ¬ τmove s' tl s''; s'' -τ-tls→* ∞ ⟧ ⟹ s -τ-LCons tl tls→* ∞"
| τinf_step_Nil: "s -τ→ ∞ ⟹ s -τ-LNil→* ∞"
coinductive τinf_step_table :: "'s ⇒ ('s × 's × 'tl × 's) llist ⇒ bool" ("_ -τ-_→*t ∞" [50, 0] 80)
where
τinf_step_table_Cons:
"⋀tl. ⟦ s -τ→* s'; s' -tl→ s''; ¬ τmove s' tl s''; s'' -τ-tls→*t ∞ ⟧ ⟹ s -τ-LCons (s, s', tl, s'') tls→*t ∞"
| τinf_step_table_Nil:
"s -τ→ ∞ ⟹ s -τ-LNil→*t ∞"
definition τinf_step2τinf_step_table :: "'s ⇒ 'tl llist ⇒ ('s × 's × 'tl × 's) llist"
where
"τinf_step2τinf_step_table s tls =
unfold_llist
(λ(s, tls). lnull tls)
(λ(s, tls). let (s', s'') = SOME (s', s''). s -τ→* s' ∧ s' -lhd tls→ s'' ∧ ¬ τmove s' (lhd tls) s'' ∧ s'' -τ-ltl tls→* ∞
in (s, s', lhd tls, s''))
(λ(s, tls). let (s', s'') = SOME (s', s''). s -τ→* s' ∧ s' -lhd tls→ s'' ∧ ¬ τmove s' (lhd tls) s'' ∧ s'' -τ-ltl tls→* ∞
in (s'', ltl tls))
(s, tls)"
definition silent_move_from :: "'s ⇒ 's ⇒ 's ⇒ bool"
where "silent_move_from s0 s1 s2 ⟷ silent_moves s0 s1 ∧ silent_move s1 s2"
inductive τrtrancl3p :: "'s ⇒ 'tl list ⇒ 's ⇒ bool" ("_ -τ-_→* _" [50, 0, 50] 60)
where
τrtrancl3p_refl: "τrtrancl3p s [] s"
| τrtrancl3p_step: "⋀tl. ⟦ s -tl→ s'; ¬ τmove s tl s'; τrtrancl3p s' tls s'' ⟧ ⟹ τrtrancl3p s (tl # tls) s''"
| τrtrancl3p_τstep: "⋀tl. ⟦ s -tl→ s'; τmove s tl s'; τrtrancl3p s' tls s'' ⟧ ⟹ τrtrancl3p s tls s''"
coinductive τRuns :: "'s ⇒ ('tl, 's option) tllist ⇒ bool" ("_ ⇓ _" [50, 50] 51)
where
Terminate: "⟦ s -τ→* s'; ⋀tl s''. ¬ s' -tl→ s'' ⟧ ⟹ s ⇓ TNil ⌊s'⌋"
| Diverge: "s -τ→ ∞ ⟹ s ⇓ TNil None"
| Proceed: "⋀tl. ⟦ s -τ→* s'; s' -tl→ s''; ¬ τmove s' tl s''; s'' ⇓ tls ⟧ ⟹ s ⇓ TCons tl tls"
inductive_simps τRuns_simps:
"s ⇓ TNil (Some s')"
"s ⇓ TNil None"
"s ⇓ TCons tl' tls"
coinductive τRuns_table :: "'s ⇒ ('tl × 's, 's option) tllist ⇒ bool"
where
Terminate: "⟦ s -τ→* s'; ⋀tl s''. ¬ s' -tl→ s'' ⟧ ⟹ τRuns_table s (TNil ⌊s'⌋)"
| Diverge: "s -τ→ ∞ ⟹ τRuns_table s (TNil None)"
| Proceed:
"⋀tl. ⟦ s -τ→* s'; s' -tl→ s''; ¬ τmove s' tl s''; τRuns_table s'' tls ⟧
⟹ τRuns_table s (TCons (tl, s'') tls)"
definition silent_move2 :: "'s ⇒ 'tl ⇒ 's ⇒ bool"
where "⋀tl. silent_move2 s tl s' ⟷ s -tl→ s' ∧ τmove s tl s'"
abbreviation silent_moves2 :: "'s ⇒ 'tl list ⇒ 's ⇒ bool"
where "silent_moves2 ≡ rtrancl3p silent_move2"
coinductive τRuns_table2 :: "'s ⇒ ('tl list × 's × 'tl × 's, ('tl list × 's) + 'tl llist) tllist ⇒ bool"
where
Terminate: "⟦ silent_moves2 s tls s'; ⋀tl s''. ¬ s' -tl→ s'' ⟧ ⟹ τRuns_table2 s (TNil (Inl (tls, s')))"
| Diverge: "trsys.inf_step silent_move2 s tls ⟹ τRuns_table2 s (TNil (Inr tls))"
| Proceed:
"⋀tl. ⟦ silent_moves2 s tls s'; s' -tl→ s''; ¬ τmove s' tl s''; τRuns_table2 s'' tlsstlss ⟧
⟹ τRuns_table2 s (TCons (tls, s', tl, s'') tlsstlss)"
inductive_simps τRuns_table2_simps:
"τRuns_table2 s (TNil tlss)"
"τRuns_table2 s (TCons tlsstls tlsstlss)"
lemma inf_step_table_all_τ_into_τdiverge:
"⟦ s -stls→*t ∞; ∀(s, tl, s') ∈ lset stls. τmove s tl s' ⟧ ⟹ s -τ→ ∞"
proof(coinduction arbitrary: s stls)
case (τdiverge s)
thus ?case by cases (auto simp add: silent_move_iff, blast)
qed
lemma inf_step_table_lappend_llist_ofD:
"s -lappend (llist_of stls) (LCons (x, tl', x') xs)→*t ∞
⟹ (s -map (fst ∘ snd) stls→* x) ∧ (x -LCons (x, tl', x') xs→*t ∞)"
proof(induct stls arbitrary: s)
case Nil thus ?case by(auto elim: inf_step_table.cases intro: inf_step_table.intros rtrancl3p_refl)
next
case (Cons st stls)
note IH = ‹⋀s. s -lappend (llist_of stls) (LCons (x, tl', x') xs)→*t ∞ ⟹
s -map (fst ∘ snd) stls→* x ∧ x -LCons (x, tl', x') xs→*t ∞›
from ‹s -lappend (llist_of (st # stls)) (LCons (x, tl', x') xs)→*t ∞›
show ?case
proof cases
case (inf_step_tableI s' stls' tl)
hence [simp]: "st = (s, tl, s')" "stls' = lappend (llist_of stls) (LCons (x, tl', x') xs)"
and "s -tl→ s'" "s' -lappend (llist_of stls) (LCons (x, tl', x') xs)→*t ∞" by simp_all
from IH[OF ‹s' -lappend (llist_of stls) (LCons (x, tl', x') xs)→*t ∞›]
have "s' -map (fst ∘ snd) stls→* x" "x -LCons (x, tl', x') xs→*t ∞" by auto
with ‹s -tl→ s'› show ?thesis by(auto simp add: o_def intro: rtrancl3p_step_converse)
qed
qed
lemma inf_step_table_lappend_llist_of_τ_into_τmoves:
assumes "lfinite stls"
shows "⟦ s -lappend stls (LCons (x, tl' x') xs)→*t ∞; ∀(s, tl, s')∈lset stls. τmove s tl s' ⟧ ⟹ s -τ→* x"
using assms
proof(induct arbitrary: s rule: lfinite.induct)
case lfinite_LNil thus ?case by(auto elim: inf_step_table.cases)
next
case (lfinite_LConsI stls st)
note IH = ‹⋀s. ⟦s -lappend stls (LCons (x, tl' x') xs)→*t ∞; ∀(s, tl, s')∈lset stls. τmove s tl s' ⟧ ⟹ s -τ→* x›
obtain s1 tl1 s1' where [simp]: "st = (s1, tl1, s1')" by(cases st)
from ‹s -lappend (LCons st stls) (LCons (x, tl' x') xs)→*t ∞›
show ?case
proof cases
case (inf_step_tableI X' STLS TL)
hence [simp]: "s1 = s" "TL = tl1" "X' = s1'" "STLS = lappend stls (LCons (x, tl' x') xs)"
and "s -tl1→ s1'" and "s1' -lappend stls (LCons (x, tl' x') xs)→*t ∞" by simp_all
from ‹∀(s, tl, s')∈lset (LCons st stls). τmove s tl s'› have "τmove s tl1 s1'" by simp
moreover
from IH[OF ‹s1' -lappend stls (LCons (x, tl' x') xs)→*t ∞›] ‹∀(s, tl, s')∈lset (LCons st stls). τmove s tl s'›
have "s1' -τ→* x" by simp
ultimately show ?thesis using ‹s -tl1→ s1'› by(auto intro: converse_rtranclp_into_rtranclp)
qed
qed
lemma inf_step_table_into_τinf_step:
"s -stls→*t ∞ ⟹ s -τ-lmap (fst ∘ snd) (lfilter (λ(s, tl, s'). ¬ τmove s tl s') stls)→* ∞"
proof(coinduction arbitrary: s stls)
case (τinf_step s stls)
let ?P = "λ(s, tl, s'). ¬ τmove s tl s'"
show ?case
proof(cases "lfilter ?P stls")
case LNil
with τinf_step have ?τinf_step_Nil
by(auto intro: inf_step_table_all_τ_into_τdiverge simp add: lfilter_eq_LNil)
thus ?thesis ..
next
case (LCons stls' xs)
obtain x tl x' where "stls' = (x, tl, x')" by(cases stls')
with LCons have stls: "lfilter ?P stls = LCons (x, tl, x') xs" by simp
from lfilter_eq_LConsD[OF this] obtain stls1 stls2
where stls1: "stls = lappend stls1 (LCons (x, tl, x') stls2)"
and "lfinite stls1"
and τs: "∀(s, tl, s')∈lset stls1. τmove s tl s'"
and nτ: "¬ τmove x tl x'" and xs: "xs = lfilter ?P stls2" by blast
from ‹lfinite stls1› τinf_step τs have "s -τ→* x" unfolding stls1
by(rule inf_step_table_lappend_llist_of_τ_into_τmoves)
moreover from ‹lfinite stls1› have "llist_of (list_of stls1) = stls1" by(simp add: llist_of_list_of)
with τinf_step stls1 have "s -lappend (llist_of (list_of stls1)) (LCons (x, tl, x') stls2)→*t ∞" by simp
from inf_step_table_lappend_llist_ofD[OF this]
have "x -LCons (x, tl, x') stls2→*t ∞" ..
hence "x -tl→ x'" "x' -stls2→*t ∞" by(auto elim: inf_step_table.cases)
ultimately have ?τinf_step_Cons using xs nτ by(auto simp add: stls o_def)
thus ?thesis ..
qed
qed
lemma inf_step_into_τinf_step:
assumes "s -tls→* ∞"
shows "∃A. s -τ-lnths tls A→* ∞"
proof -
from inf_step_imp_inf_step_table[OF assms]
obtain stls where "s -stls→*t ∞" and tls: "tls = lmap (fst ∘ snd) stls" by blast
from ‹s -stls→*t ∞› have "s -τ-lmap (fst ∘ snd) (lfilter (λ(s, tl, s'). ¬ τmove s tl s') stls)→* ∞"
by(rule inf_step_table_into_τinf_step)
hence "s -τ-lnths tls {n. enat n < llength stls ∧ (λ(s, tl, s'). ¬ τmove s tl s') (lnth stls n)}→* ∞"
unfolding lfilter_conv_lnths tls by simp
thus ?thesis by blast
qed
lemma silent_moves_into_τrtrancl3p:
"s -τ→* s' ⟹ s -τ-[]→* s'"
by(induct rule: converse_rtranclp_induct)(blast intro: τrtrancl3p.intros)+
lemma τrtrancl3p_into_silent_moves:
"s -τ-[]→* s' ⟹ s -τ→* s'"
apply(induct s tls≡"[] :: 'tl list" s' rule: τrtrancl3p.induct)
apply(auto intro: converse_rtranclp_into_rtranclp)
done
lemma τrtrancl3p_Nil_eq_τmoves:
"s -τ-[]→* s' ⟷ s -τ→* s'"
by(blast intro: silent_moves_into_τrtrancl3p τrtrancl3p_into_silent_moves)
lemma τrtrancl3p_trans [trans]:
"⟦ s -τ-tls→* s'; s' -τ-tls'→* s'' ⟧ ⟹ s -τ-tls @ tls'→* s''"
apply(induct rule: τrtrancl3p.induct)
apply(auto intro: τrtrancl3p.intros)
done
lemma τrtrancl3p_SingletonE:
fixes tl
assumes red: "s -τ-[tl]→* s'''"
obtains s' s'' where "s -τ→* s'" "s' -tl→ s''" "¬ τmove s' tl s''" "s'' -τ→* s'''"
proof(atomize_elim)
from red show "∃s' s''. s -τ→* s' ∧ s' -tl→ s'' ∧ ¬ τmove s' tl s'' ∧ s'' -τ→* s'''"
proof(induct s tls≡"[tl]" s''')
case (τrtrancl3p_step s s' s'')
from ‹s -tl→ s'› ‹¬ τmove s tl s'› ‹s' -τ-[]→* s''› show ?case
by(auto simp add: τrtrancl3p_Nil_eq_τmoves)
next
case (τrtrancl3p_τstep s s' s'' tl')
then obtain t' t'' where "s' -τ→* t'" "t' -tl→ t''" "¬ τmove t' tl t''" "t'' -τ→* s''" by auto
moreover
from ‹s -tl'→ s'› ‹τmove s tl' s'› have "s -τ→* s'" by blast
ultimately show ?case by(auto intro: rtranclp_trans)
qed
qed
lemma τrtrancl3p_snocI:
"⋀tl. ⟦ τrtrancl3p s tls s''; s'' -τ→* s'''; s''' -tl→ s'; ¬ τmove s''' tl s' ⟧
⟹ τrtrancl3p s (tls @ [tl]) s'"
apply(erule τrtrancl3p_trans)
apply(fold τrtrancl3p_Nil_eq_τmoves)
apply(drule τrtrancl3p_trans)
apply(erule (1) τrtrancl3p_step)
apply(rule τrtrancl3p_refl)
apply simp
done
lemma τdiverge_rtranclp_silent_move:
"⟦ silent_move^** s s'; s' -τ→ ∞ ⟧ ⟹ s -τ→ ∞"
by(induct rule: converse_rtranclp_induct)(auto intro: τdivergeI)
lemma τdiverge_trancl_coinduct [consumes 1, case_names τdiverge]:
assumes X: "X s"
and step: "⋀s. X s ⟹ ∃s'. silent_move^++ s s' ∧ (X s' ∨ s' -τ→ ∞)"
shows "s -τ→ ∞"
proof -
from X have "∃s'. silent_move^** s s' ∧ X s'" by blast
thus ?thesis
proof(coinduct)
case (τdiverge s)
then obtain s' where "silent_move⇧*⇧* s s'" "X s'" by blast
from step[OF ‹X s'›] obtain s'''
where "silent_move^++ s' s'''" "X s''' ∨ s''' -τ→ ∞" by blast
from ‹silent_move⇧*⇧* s s'› show ?case
proof(cases rule: converse_rtranclpE[consumes 1, case_names refl step])
case refl
moreover from tranclpD[OF ‹silent_move^++ s' s'''›] obtain s''
where "silent_move s' s''" "silent_move^** s'' s'''" by blast
ultimately show ?thesis using ‹silent_move^** s'' s'''› ‹X s''' ∨ s''' -τ→ ∞›
by(auto intro: τdiverge_rtranclp_silent_move)
next
case (step S)
moreover from ‹silent_move⇧*⇧* S s'› ‹silent_move^++ s' s'''›
have "silent_move^** S s'''" by(rule rtranclp_trans[OF _ tranclp_into_rtranclp])
ultimately show ?thesis using ‹X s''' ∨ s''' -τ→ ∞› by(auto intro: τdiverge_rtranclp_silent_move)
qed
qed
qed
lemma τdiverge_trancl_measure_coinduct [consumes 2, case_names τdiverge]:
assumes major: "X s t" "wfP μ"
and step: "⋀s t. X s t ⟹ ∃s' t'. (μ t' t ∧ s' = s ∨ silent_move^++ s s') ∧ (X s' t' ∨ s' -τ→ ∞)"
shows "s -τ→ ∞"
proof -
{ fix s t
assume "X s t"
with ‹wfP μ› have "∃s' t'. silent_move^++ s s' ∧ (X s' t' ∨ s' -τ→ ∞)"
proof(induct arbitrary: s rule: wfP_induct[consumes 1])
case (1 t)
hence IH: "⋀s' t'. ⟦ μ t' t; X s' t' ⟧ ⟹
∃s'' t''. silent_move^++ s' s'' ∧ (X s'' t'' ∨ s'' -τ→ ∞)" by blast
from step[OF ‹X s t›] obtain s' t'
where "μ t' t ∧ s' = s ∨ silent_move⇧+⇧+ s s'" "X s' t' ∨ s' -τ→ ∞" by blast
from ‹μ t' t ∧ s' = s ∨ silent_move⇧+⇧+ s s'› show ?case
proof
assume "μ t' t ∧ s' = s"
hence "μ t' t" and [simp]: "s' = s" by simp_all
from ‹X s' t' ∨ s' -τ→ ∞› show ?thesis
proof
assume "X s' t'"
from IH[OF ‹μ t' t› this] show ?thesis by simp
next
assume "s' -τ→ ∞" thus ?thesis
by cases(auto simp add: silent_move_iff)
qed
next
assume "silent_move⇧+⇧+ s s'"
thus ?thesis using ‹X s' t' ∨ s' -τ→ ∞› by blast
qed
qed }
note X = this
from ‹X s t› have "∃t. X s t" ..
thus ?thesis
proof(coinduct rule: τdiverge_trancl_coinduct)
case (τdiverge s)
then obtain t where "X s t" ..
from X[OF this] show ?case by blast
qed
qed
lemma τinf_step2τinf_step_table_LNil [simp]: "τinf_step2τinf_step_table s LNil = LNil"
by(simp add: τinf_step2τinf_step_table_def)
lemma τinf_step2τinf_step_table_LCons [simp]:
fixes s tl ss tls
defines "ss ≡ SOME (s', s''). s -τ→* s' ∧ s' -tl→ s'' ∧ ¬ τmove s' tl s'' ∧ s'' -τ-tls→* ∞"
shows
"τinf_step2τinf_step_table s (LCons tl tls) =
LCons (s, fst ss, tl, snd ss) (τinf_step2τinf_step_table (snd ss) tls)"
by(simp add: ss_def τinf_step2τinf_step_table_def split_beta)
lemma lnull_τinf_step2τinf_step_table [simp]:
"lnull (τinf_step2τinf_step_table s tls) ⟷ lnull tls"
by(simp add: τinf_step2τinf_step_table_def)
lemma lhd_τinf_step2τinf_step_table [simp]:
"¬ lnull tls ⟹ lhd (τinf_step2τinf_step_table s tls) =
(let (s', s'') = SOME (s', s''). s -τ→* s' ∧ s' -lhd tls→ s'' ∧ ¬ τmove s' (lhd tls) s'' ∧ s'' -τ-ltl tls→* ∞
in (s, s', lhd tls, s''))"
unfolding τinf_step2τinf_step_table_def Let_def by simp
lemma ltl_τinf_step2τinf_step_table [simp]:
"¬ lnull tls ⟹ ltl (τinf_step2τinf_step_table s tls) =
(let (s', s'') = SOME (s', s''). s -τ→* s' ∧ s' -lhd tls→ s'' ∧ ¬ τmove s' (lhd tls) s'' ∧ s'' -τ-ltl tls→* ∞
in τinf_step2τinf_step_table s'' (ltl tls))"
unfolding τinf_step2τinf_step_table_def Let_def
by(simp add: split_beta)
lemma lmap_τinf_step2τinf_step_table: "lmap (fst ∘ snd ∘ snd) (τinf_step2τinf_step_table s tls) = tls"
by(coinduction arbitrary: s tls)(auto simp add: split_beta)
lemma τinf_step_into_τinf_step_table:
"s -τ-tls→* ∞ ⟹ s -τ-τinf_step2τinf_step_table s tls→*t ∞"
proof(coinduction arbitrary: s tls)
case (τinf_step_table s tls)
thus ?case
proof(cases)
case (τinf_step_Cons s' s'' tls' tl)
let ?ss = "SOME (s', s''). s -τ→* s' ∧ s' -tl→ s'' ∧ ¬ τmove s' tl s'' ∧ s'' -τ-tls'→* ∞"
from τinf_step_Cons have tls: "tls = LCons tl tls'" and "s -τ→* s'" "s' -tl→ s''"
"¬ τmove s' tl s''" "s'' -τ-tls'→* ∞" by simp_all
hence "(λ(s', s''). s -τ→* s' ∧ s' -tl→ s'' ∧ ¬ τmove s' tl s'' ∧ s'' -τ-tls'→* ∞) (s', s'')" by simp
hence "(λ(s', s''). s -τ→* s' ∧ s' -tl→ s'' ∧ ¬ τmove s' tl s'' ∧ s'' -τ-tls'→* ∞) ?ss" by(rule someI)
with tls have ?τinf_step_table_Cons by auto
thus ?thesis ..
next
case τinf_step_Nil
then have ?τinf_step_table_Nil by simp
thus ?thesis ..
qed
qed
lemma τinf_step_imp_τinf_step_table:
assumes "s -τ-tls→* ∞"
shows "∃sstls. s -τ-sstls→*t ∞ ∧ tls = lmap (fst ∘ snd ∘ snd) sstls"
using τinf_step_into_τinf_step_table[OF assms]
by(auto simp only: lmap_τinf_step2τinf_step_table)
lemma τinf_step_table_into_τinf_step:
"s -τ-sstls→*t ∞ ⟹ s -τ-lmap (fst ∘ snd ∘ snd) sstls→* ∞"
proof(coinduction arbitrary: s sstls)
case (τinf_step s tls)
thus ?case by cases(auto simp add: o_def)
qed
lemma silent_move_fromI [intro]:
"⟦ silent_moves s0 s1; silent_move s1 s2 ⟧ ⟹ silent_move_from s0 s1 s2"
by(simp add: silent_move_from_def)
lemma silent_move_fromE [elim]:
assumes "silent_move_from s0 s1 s2"
obtains "silent_moves s0 s1" "silent_move s1 s2"
using assms by(auto simp add: silent_move_from_def)
lemma rtranclp_silent_move_from_imp_silent_moves:
assumes s'x: "silent_move⇧*⇧* s' x"
shows "(silent_move_from s')^** x z ⟹ silent_moves s' z"
by(induct rule: rtranclp_induct)(auto intro: s'x)
lemma τdiverge_not_wfP_silent_move_from:
assumes "s -τ→ ∞"
shows "¬ wfP (flip (silent_move_from s))"
proof
assume "wfP (flip (silent_move_from s))"
moreover define Q where "Q = {s'. silent_moves s s' ∧ s' -τ→ ∞}"
hence "s ∈ Q" using ‹s -τ→ ∞› by(auto)
ultimately have "∃z∈Q. ∀y. silent_move_from s z y ⟶ y ∉ Q"
unfolding wfP_eq_minimal flip_simps by blast
then obtain z where "z ∈ Q"
and min: "⋀y. silent_move_from s z y ⟹ y ∉ Q" by blast
from ‹z ∈ Q› have "silent_moves s z" "z -τ→ ∞" unfolding Q_def by auto
from ‹z -τ→ ∞› obtain y where "silent_move z y" "y -τ→ ∞" by cases auto
from ‹silent_moves s z› ‹silent_move z y› have "silent_move_from s z y" ..
hence "y ∉ Q" by(rule min)
moreover from ‹silent_moves s z› ‹silent_move z y› ‹y -τ→ ∞›
have "y ∈ Q" unfolding Q_def by auto
ultimately show False by contradiction
qed
lemma wfP_silent_move_from_unroll:
assumes wfPs': "⋀s'. s -τ→ s' ⟹ wfP (flip (silent_move_from s'))"
shows "wfP (flip (silent_move_from s))"
unfolding wfP_eq_minimal flip_conv
proof(intro allI impI)
fix Q and x :: 's
assume "x ∈ Q"
show "∃z∈Q. ∀y. silent_move_from s z y ⟶ y ∉ Q"
proof(cases "∃s'. s -τ→ s' ∧ (∃x'. silent_moves s' x' ∧ x' ∈ Q)")
case False
hence "∀y. silent_move_from s x y ⟶ ¬ y ∈ Q"
by(cases "x=s")(auto, blast elim: converse_rtranclpE intro: rtranclp.rtrancl_into_rtrancl)
with ‹x ∈ Q› show ?thesis by blast
next
case True
then obtain s' x' where "s -τ→ s'" and "silent_moves s' x'" and "x' ∈ Q"
by auto
from ‹s -τ→ s'› have "wfP (flip (silent_move_from s'))" by(rule wfPs')
from this ‹x' ∈ Q› obtain z where "z ∈ Q" and min: "⋀y. silent_move_from s' z y ⟹ ¬ y ∈ Q"
and "(silent_move_from s')^** x' z"
by (rule wfP_minimalE) (unfold flip_simps, blast)
{ fix y
assume "silent_move_from s z y"
with ‹(silent_move_from s')^** x' z› ‹silent_move^** s' x'›
have "silent_move_from s' z y"
by(blast intro: rtranclp_silent_move_from_imp_silent_moves)
hence "¬ y ∈ Q" by(rule min) }
with ‹z ∈ Q› show ?thesis by(auto simp add: intro!: bexI)
qed
qed
lemma not_wfP_silent_move_from_τdiverge:
assumes "¬ wfP (flip (silent_move_from s))"
shows "s -τ→ ∞"
using assms
proof(coinduct)
case (τdiverge s)
{ assume wfPs': "⋀s'. s -τ→ s' ⟹ wfP (flip (silent_move_from s'))"
hence "wfP (flip (silent_move_from s))" by(rule wfP_silent_move_from_unroll) }
with τdiverge have "∃s'. s -τ→ s' ∧ ¬ wfP (flip (silent_move_from s'))" by auto
thus ?case by blast
qed
lemma τdiverge_neq_wfP_silent_move_from:
"s -τ→ ∞ ≠ wfP (flip (silent_move_from s))"
by(auto intro: not_wfP_silent_move_from_τdiverge dest: τdiverge_not_wfP_silent_move_from)
lemma not_τdiverge_to_no_τmove:
assumes "¬ s -τ→ ∞"
shows "∃s'. s -τ→* s' ∧ (∀s''. ¬ s' -τ→ s'')"
proof -
define S where "S = s"
from ‹¬ τdiverge s› have "wfP (flip (silent_move_from S))" unfolding S_def
using τdiverge_neq_wfP_silent_move_from[of s] by simp
moreover have "silent_moves S s" unfolding S_def ..
ultimately show ?thesis
proof(induct rule: wfP_induct')
case (wfP s)
note IH = ‹⋀y. ⟦flip (silent_move_from S) y s; S -τ→* y ⟧
⟹ ∃s'. y -τ→* s' ∧ (∀s''. ¬ s' -τ→ s'')›
show ?case
proof(cases "∃s'. silent_move s s'")
case False thus ?thesis by auto
next
case True
then obtain s' where "s -τ→ s'" ..
with ‹S -τ→* s› have "flip (silent_move_from S) s' s"
unfolding flip_conv by(rule silent_move_fromI)
moreover from ‹S -τ→* s› ‹s -τ→ s'› have "S -τ→* s'" ..
ultimately have "∃s''. s' -τ→* s'' ∧ (∀s'''. ¬ s'' -τ→ s''')" by(rule IH)
then obtain s'' where "s' -τ→* s''" "∀s'''. ¬ s'' -τ→ s'''" by blast
from ‹s -τ→ s'› ‹s' -τ→* s''› have "s -τ→* s''" by(rule converse_rtranclp_into_rtranclp)
with ‹∀s'''. ¬ s'' -τ→ s'''› show ?thesis by blast
qed
qed
qed
lemma τdiverge_conv_τRuns:
"s -τ→ ∞ ⟷ s ⇓ TNil None"
by(auto intro: τRuns.Diverge elim: τRuns.cases)
lemma τinf_step_into_τRuns:
"s -τ-tls→* ∞ ⟹ s ⇓ tllist_of_llist None tls"
proof(coinduction arbitrary: s tls)
case (τRuns s tls')
thus ?case by cases(auto simp add: τdiverge_conv_τRuns)
qed
lemma τ_into_τRuns:
"⟦ s -τ→ s'; s' ⇓ tls ⟧ ⟹ s ⇓ tls"
by(blast elim: τRuns.cases intro: τRuns.intros τdiverge.intros converse_rtranclp_into_rtranclp)
lemma τrtrancl3p_into_τRuns:
assumes "s -τ-tls→* s'"
and "s' ⇓ tls'"
shows "s ⇓ lappendt (llist_of tls) tls'"
using assms
by induct(auto intro: τRuns.Proceed τ_into_τRuns)
lemma τRuns_table_into_τRuns:
"τRuns_table s stlsss ⟹ s ⇓ tmap fst id stlsss"
proof(coinduction arbitrary: s stlsss)
case (τRuns s tls)
thus ?case by cases(auto simp add: o_def id_def)
qed
definition τRuns2τRuns_table :: "'s ⇒ ('tl, 's option) tllist ⇒ ('tl × 's, 's option) tllist"
where
"τRuns2τRuns_table s tls = unfold_tllist
(λ(s, tls). is_TNil tls)
(λ(s, tls). terminal tls)
(λ(s, tls). (thd tls, SOME s''. ∃s'. s -τ→* s' ∧ s' -thd tls→ s'' ∧ ¬ τmove s' (thd tls) s'' ∧ s'' ⇓ ttl tls))
(λ(s, tls). (SOME s''. ∃s'. s -τ→* s' ∧ s' -thd tls→ s'' ∧ ¬ τmove s' (thd tls) s'' ∧ s'' ⇓ ttl tls, ttl tls))
(s, tls)"
lemma is_TNil_τRuns2τRuns_table [simp]:
"is_TNil (τRuns2τRuns_table s tls) ⟷ is_TNil tls"
thm unfold_tllist.disc
by(simp add: τRuns2τRuns_table_def)
lemma thd_τRuns2τRuns_table [simp]:
"¬ is_TNil tls ⟹
thd (τRuns2τRuns_table s tls) =
(thd tls, SOME s''. ∃s'. s -τ→* s' ∧ s' -thd tls→ s'' ∧ ¬ τmove s' (thd tls) s'' ∧ s'' ⇓ ttl tls)"
by(simp add: τRuns2τRuns_table_def)
lemma ttl_τRuns2τRuns_table [simp]:
"¬ is_TNil tls ⟹
ttl (τRuns2τRuns_table s tls) =
τRuns2τRuns_table (SOME s''. ∃s'. s -τ→* s' ∧ s' -thd tls→ s'' ∧ ¬ τmove s' (thd tls) s'' ∧ s'' ⇓ ttl tls) (ttl tls)"
by(simp add: τRuns2τRuns_table_def)
lemma terminal_τRuns2τRuns_table [simp]:
"is_TNil tls ⟹ terminal (τRuns2τRuns_table s tls) = terminal tls"
by(simp add: τRuns2τRuns_table_def)
lemma τRuns2τRuns_table_simps [simp, nitpick_simp]:
"τRuns2τRuns_table s (TNil so) = TNil so"
"⋀tl.
τRuns2τRuns_table s (TCons tl tls) =
(let s'' = SOME s''. ∃s'. s -τ→* s' ∧ s' -tl→ s'' ∧ ¬ τmove s' tl s'' ∧ s'' ⇓ tls
in TCons (tl, s'') (τRuns2τRuns_table s'' tls))"
apply(simp add: τRuns2τRuns_table_def)
apply(rule tllist.expand)
apply(simp_all)
done
lemma τRuns2τRuns_table_inverse:
"tmap fst id (τRuns2τRuns_table s tls) = tls"
by(coinduction arbitrary: s tls) auto
lemma τRuns_into_τRuns_table:
assumes "s ⇓ tls"
shows "∃stlsss. tls = tmap fst id stlsss ∧ τRuns_table s stlsss"
proof(intro exI conjI)
from assms show "τRuns_table s (τRuns2τRuns_table s tls)"
proof(coinduction arbitrary: s tls)
case (τRuns_table s tls)
thus ?case
proof cases
case (Terminate s')
hence ?Terminate by simp
thus ?thesis ..
next
case Diverge
hence ?Diverge by simp
thus ?thesis by simp
next
case (Proceed s' s'' tls' tl)
let ?P = "λs''. ∃s'. s -τ→* s' ∧ s' -tl→ s'' ∧ ¬ τmove s' tl s'' ∧ s'' ⇓ tls'"
from Proceed have "?P s''" by auto
hence "?P (Eps ?P)" by(rule someI)
hence ?Proceed using ‹tls = TCons tl tls'›
by(auto simp add: split_beta)
thus ?thesis by simp
qed
qed
qed(simp add: τRuns2τRuns_table_inverse)
lemma τRuns_lappendtE:
assumes "σ ⇓ lappendt tls tls'"
and "lfinite tls"
obtains σ' where "σ -τ-list_of tls→* σ'"
and "σ' ⇓ tls'"
proof(atomize_elim)
from ‹lfinite tls› ‹σ ⇓ lappendt tls tls'›
show "∃σ'. σ -τ-list_of tls→* σ' ∧ σ' ⇓ tls'"
proof(induct arbitrary: σ)
case lfinite_LNil thus ?case by(auto intro: τrtrancl3p_refl)
next
case (lfinite_LConsI tls tl)
from ‹σ ⇓ lappendt (LCons tl tls) tls'›
show ?case unfolding lappendt_LCons
proof(cases)
case (Proceed σ' σ'')
from ‹σ'' ⇓ lappendt tls tls' ⟹ ∃σ'''. σ'' -τ-list_of tls→* σ''' ∧ σ''' ⇓ tls'› ‹σ'' ⇓ lappendt tls tls'›
obtain σ''' where "σ'' -τ-list_of tls→* σ'''" "σ''' ⇓ tls'" by blast
from ‹σ' -tl→ σ''› ‹¬ τmove σ' tl σ''› ‹σ'' -τ-list_of tls→* σ'''›
have "σ' -τ-tl # list_of tls→* σ'''" by(rule τrtrancl3p_step)
with ‹σ -τ→* σ'› have "σ -τ-[] @ (tl # list_of tls)→* σ'''"
unfolding τrtrancl3p_Nil_eq_τmoves[symmetric] by(rule τrtrancl3p_trans)
with ‹lfinite tls› have "σ -τ-list_of (LCons tl tls)→* σ'''" by(simp add: list_of_LCons)
with ‹σ''' ⇓ tls'› show ?thesis by blast
qed
qed
qed
lemma τRuns_total:
"∃tls. σ ⇓ tls"
proof
let ?τhalt = "λσ σ'. σ -τ→* σ' ∧ (∀tl σ''. ¬ σ' -tl→ σ'')"
let ?τdiverge = "λσ. σ -τ→ ∞"
let ?proceed = "λσ (tl, σ''). ∃σ'. σ -τ→* σ' ∧ σ' -tl→ σ'' ∧ ¬ τmove σ' tl σ''"
define tls where "tls = unfold_tllist
(λσ. (∃σ'. ?τhalt σ σ') ∨ ?τdiverge σ)
(λσ. if ∃σ'. ?τhalt σ σ' then Some (SOME σ'. ?τhalt σ σ') else None)
(λσ. fst (SOME tlσ'. ?proceed σ tlσ'))
(λσ. snd (SOME tlσ'. ?proceed σ tlσ')) σ"
then show "σ ⇓ tls"
proof(coinduct σ tls rule: τRuns.coinduct)
case (τRuns σ tls)
show ?case
proof(cases "∃σ'. ?τhalt σ σ'")
case True
hence "?τhalt σ (SOME σ'. ?τhalt σ σ')" by(rule someI_ex)
hence ?Terminate using True unfolding τRuns by simp
thus ?thesis ..
next
case False
note τhalt = this
show ?thesis
proof(cases "?τdiverge σ")
case True
hence ?Diverge using False unfolding τRuns by simp
thus ?thesis by simp
next
case False
from not_τdiverge_to_no_τmove[OF this]
obtain σ' where σ_σ': "σ -τ→* σ'"
and no_τ: "⋀σ''. ¬ σ' -τ→ σ''" by blast
from σ_σ' τhalt obtain tl σ'' where "σ' -tl→ σ''" by auto
moreover with no_τ[of σ''] have "¬ τmove σ' tl σ''" by auto
ultimately have "?proceed σ (tl, σ'')" using σ_σ' by auto
hence "?proceed σ (SOME tlσ. ?proceed σ tlσ)" by(rule someI)
hence ?Proceed using False τhalt unfolding τRuns
by(subst unfold_tllist.code) fastforce
thus ?thesis by simp
qed
qed
qed
qed
lemma silent_move2_into_silent_move:
fixes tl
assumes "silent_move2 s tl s'"
shows "s -τ→ s'"
using assms by(auto simp add: silent_move2_def)
lemma silent_move_into_silent_move2:
assumes "s -τ→ s'"
shows "∃tl. silent_move2 s tl s'"
using assms by(auto simp add: silent_move2_def)
lemma silent_moves2_into_silent_moves:
assumes "silent_moves2 s tls s'"
shows "s -τ→* s'"
using assms
by(induct)(blast intro: silent_move2_into_silent_move rtranclp.rtrancl_into_rtrancl)+
lemma silent_moves_into_silent_moves2:
assumes "s -τ→* s'"
shows "∃tls. silent_moves2 s tls s'"
using assms
by(induct)(blast dest: silent_move_into_silent_move2 intro: rtrancl3p_step)+
lemma inf_step_silent_move2_into_τdiverge:
"trsys.inf_step silent_move2 s tls ⟹ s -τ→ ∞"
proof(coinduction arbitrary: s tls)
case (τdiverge s)
thus ?case
by(cases rule: trsys.inf_step.cases[consumes 1])(auto intro: silent_move2_into_silent_move)
qed
lemma τdiverge_into_inf_step_silent_move2:
assumes "s -τ→ ∞"
obtains tls where "trsys.inf_step silent_move2 s tls"
proof -
define tls where "tls = unfold_llist
(λ_. False)
(λs. fst (SOME (tl, s'). silent_move2 s tl s' ∧ s' -τ→ ∞))
(λs. snd (SOME (tl, s'). silent_move2 s tl s' ∧ s' -τ→ ∞))
s" (is "_ = ?tls s")
with assms have "s -τ→ ∞ ∧ tls = ?tls s" by simp
hence "trsys.inf_step silent_move2 s tls"
proof(coinduct rule: trsys.inf_step.coinduct[consumes 1, case_names inf_step, case_conclusion inf_step step])
case (inf_step s tls)
let ?P = "λ(tl, s'). silent_move2 s tl s' ∧ s' -τ→ ∞"
from inf_step obtain "s -τ→ ∞" and tls: "tls = ?tls s" ..
from ‹s -τ→ ∞› obtain s' where "s -τ→ s'" "s' -τ→ ∞" by cases
from ‹s -τ→ s'› obtain tl where "silent_move2 s tl s'"
by(blast dest: silent_move_into_silent_move2)
with ‹s' -τ→ ∞› have "?P (tl, s')" by simp
hence "?P (Eps ?P)" by(rule someI)
thus ?case using tls
by(subst (asm) unfold_llist.code)(auto)
qed
thus thesis by(rule that)
qed
lemma τRuns_into_τrtrancl3p:
assumes runs: "s ⇓ tlss"
and fin: "tfinite tlss"
and terminal: "terminal tlss = Some s'"
shows "τrtrancl3p s (list_of (llist_of_tllist tlss)) s'"
using fin runs terminal
proof(induct arbitrary: s rule: tfinite_induct)
case TNil thus ?case by cases(auto intro: silent_moves_into_τrtrancl3p)
next
case (TCons tl tlss)
from ‹s ⇓ TCons tl tlss› obtain s'' s'''
where step: "s -τ→* s''"
and step2: "s'' -tl→ s'''" "¬ τmove s'' tl s'''"
and "s''' ⇓ tlss" by cases
from ‹terminal (TCons tl tlss) = ⌊s'⌋› have "terminal tlss = ⌊s'⌋" by simp
with ‹s''' ⇓ tlss› have "s''' -τ-list_of (llist_of_tllist tlss)→* s'" by(rule TCons)
with step2 have "s'' -τ-tl # list_of (llist_of_tllist tlss)→* s'" by(rule τrtrancl3p_step)
with step have "s -τ-[] @ tl # list_of (llist_of_tllist tlss)→* s'"
by(rule τrtrancl3p_trans[OF silent_moves_into_τrtrancl3p])
thus ?case using ‹tfinite tlss› by simp
qed
lemma τRuns_terminal_stuck:
assumes Runs: "s ⇓ tlss"
and fin: "tfinite tlss"
and terminal: "terminal tlss = Some s'"
and proceed: "s' -tls→ s''"
shows False
using fin Runs terminal
proof(induct arbitrary: s rule: tfinite_induct)
case TNil thus ?case using proceed by cases auto
next
case TCons thus ?case by(fastforce elim: τRuns.cases)
qed
lemma Runs_table_silent_diverge:
"⟦ Runs_table s stlss; ∀(s, tl, s') ∈ lset stlss. τmove s tl s'; ¬ lfinite stlss ⟧
⟹ s -τ→ ∞"
proof(coinduction arbitrary: s stlss)
case (τdiverge s)
thus ?case by cases(auto 5 2)
qed
lemma Runs_table_silent_rtrancl:
assumes "lfinite stlss"
and "Runs_table s stlss"
and "∀(s, tl, s') ∈ lset stlss. τmove s tl s'"
shows "s -τ→* llast (LCons s (lmap (λ(s, tl, s'). s') stlss))" (is ?thesis1)
and "llast (LCons s (lmap (λ(s, tl, s'). s') stlss)) -tl'→ s'' ⟹ False" (is "PROP ?thesis2")
proof -
from assms have "?thesis1 ∧ (llast (LCons s (lmap (λ(s, tl, s'). s') stlss)) -tl'→ s'' ⟶ False)"
proof(induct arbitrary: s)
case lfinite_LNil thus ?case by(auto elim: Runs_table.cases)
next
case (lfinite_LConsI stlss stls)
from ‹Runs_table s (LCons stls stlss)›
obtain tl s' where [simp]: "stls = (s, tl, s')"
and "s -tl→ s'" and Run': "Runs_table s' stlss" by cases
from ‹∀(s, tl, s')∈lset (LCons stls stlss). τmove s tl s'›
have "τmove s tl s'" and silent': "∀(s, tl, s')∈lset stlss. τmove s tl s'" by simp_all
from ‹s -tl→ s'› ‹τmove s tl s'› have "s -τ→ s'" by auto
moreover from Run' silent'
have "s' -τ→* llast (LCons s' (lmap (λ(s, tl, s'). s') stlss)) ∧
(llast (LCons s' (lmap (λ(s, tl, s'). s') stlss)) -tl'→ s'' ⟶ False)"
by(rule lfinite_LConsI)
ultimately show ?case by(auto)
qed
thus ?thesis1 "PROP ?thesis2" by blast+
qed
lemma Runs_table_silent_lappendD:
fixes s stlss
defines "s' ≡ llast (LCons s (lmap (λ(s, tl, s'). s') stlss))"
assumes Runs: "Runs_table s (lappend stlss stlss')"
and fin: "lfinite stlss"
and silent: "∀(s, tl, s') ∈ lset stlss. τmove s tl s'"
shows "s -τ→* s'" (is ?thesis1)
and "Runs_table s' stlss'" (is ?thesis2)
and "stlss' ≠ LNil ⟹ s' = fst (lhd stlss')" (is "PROP ?thesis3")
proof -
from fin Runs silent
have "?thesis1 ∧ ?thesis2 ∧ (stlss' ≠ LNil ⟶ s' = fst (lhd stlss'))"
unfolding s'_def
proof(induct arbitrary: s)
case lfinite_LNil thus ?case
by(auto simp add: neq_LNil_conv Runs_table_simps)
next
case lfinite_LConsI thus ?case
by(clarsimp simp add: neq_LNil_conv Runs_table_simps)(blast intro: converse_rtranclp_into_rtranclp)
qed
thus ?thesis1 ?thesis2 "PROP ?thesis3" by simp_all
qed
lemma Runs_table_into_τRuns:
fixes s stlss
defines "tls ≡ tmap (λ(s, tl, s'). tl) id (tfilter None (λ(s, tl, s'). ¬ τmove s tl s') (tllist_of_llist (Some (llast (LCons s (lmap (λ(s, tl, s'). s') stlss)))) stlss))"
(is "_ ≡ ?conv s stlss")
assumes "Runs_table s stlss"
shows "τRuns s tls"
using assms
proof(coinduction arbitrary: s tls stlss)
case (τRuns s tls stlss)
note tls = ‹tls = ?conv s stlss›
and Run = ‹Runs_table s stlss›
show ?case
proof(cases tls)
case [simp]: (TNil so)
from tls
have silent: "∀(s, tl, s') ∈ lset stlss. τmove s tl s'"
by(auto simp add: TNil_eq_tmap_conv tfilter_empty_conv)
show ?thesis
proof(cases "lfinite stlss")
case False
with Run silent have "s -τ→ ∞" by(rule Runs_table_silent_diverge)
hence ?Diverge using False tls by(simp add: TNil_eq_tmap_conv tfilter_empty_conv)
thus ?thesis by simp
next
case True
with Runs_table_silent_rtrancl[OF this Run silent]
have ?Terminate using tls
by(auto simp add: TNil_eq_tmap_conv tfilter_empty_conv terminal_tllist_of_llist split_def)
thus ?thesis by simp
qed
next
case [simp]: (TCons tl tls')
from tls obtain s' s'' stlss'
where tl': "tfilter None (λ(s, tl, s'). ¬ τmove s tl s') (tllist_of_llist ⌊llast (LCons s (lmap (λ(s, tl, s'). s') stlss))⌋ stlss) = TCons (s', tl, s'') stlss'"
and tls': "tls' = tmap (λ(s, tl, s'). tl) id stlss'"
by(simp add: TCons_eq_tmap_conv split_def id_def split_paired_Ex) blast
from tfilter_eq_TConsD[OF tl']
obtain stlsτ rest
where stlss_eq: "tllist_of_llist ⌊llast (LCons s (lmap (λ(s, tl, s'). s') stlss))⌋ stlss = lappendt stlsτ (TCons (s', tl, s'') rest)"
and fin: "lfinite stlsτ"
and silent: "∀(s, tl, s')∈lset stlsτ. τmove s tl s'"
and "¬ τmove s' tl s''"
and stlss': "stlss' = tfilter None (λ(s, tl, s'). ¬ τmove s tl s') rest"
by(auto simp add: split_def)
from stlss_eq fin obtain rest'
where stlss: "stlss = lappend stlsτ rest'"
and rest': "tllist_of_llist ⌊llast (LCons s (lmap (λ(s, tl, s'). s') stlss))⌋ rest' = TCons (s', tl, s'') rest"
unfolding tllist_of_llist_eq_lappendt_conv by auto
hence "rest' ≠ LNil" by clarsimp
from Run[unfolded stlss] fin silent
have "s -τ→* llast (LCons s (lmap (λ(s, tl, s'). s') stlsτ))"
and "Runs_table (llast (LCons s (lmap (λ(s, tl, s'). s') stlsτ))) rest'"
and "llast (LCons s (lmap (λ(s, tl, s'). s') stlsτ)) = fst (lhd rest')"
by(rule Runs_table_silent_lappendD)+(simp add: ‹rest' ≠ LNil›)
moreover with rest' ‹rest' ≠ LNil› stlss fin obtain rest''
where rest': "rest' = LCons (s', tl, s'') rest''"
and rest: "rest = tllist_of_llist ⌊llast (LCons s'' (lmap (λ(s, tl, s'). s') rest''))⌋ rest''"
by(clarsimp simp add: neq_LNil_conv llast_LCons lmap_lappend_distrib)
ultimately have "s -τ→* s'" "s' -tl→ s''" "Runs_table s'' rest''"
by(simp_all add: Runs_table_simps)
hence ?Proceed using ‹¬ τmove s' tl s''› tls' stlss' rest
by(auto simp add: id_def)
thus ?thesis by simp
qed
qed
lemma τRuns_table2_into_τRuns:
"τRuns_table2 s tlsstlss
⟹ s ⇓ tmap (λ(tls, s', tl, s''). tl) (λx. case x of Inl (tls, s') ⇒ Some s' | Inr _ ⇒ None) tlsstlss"
proof(coinduction arbitrary: s tlsstlss)
case (τRuns s tlsstlss)
thus ?case by cases(auto intro: silent_moves2_into_silent_moves inf_step_silent_move2_into_τdiverge)
qed
lemma τRuns_into_τRuns_table2:
assumes "s ⇓ tls"
obtains tlsstlss
where "τRuns_table2 s tlsstlss"
and "tls = tmap (λ(tls, s', tl, s''). tl) (λx. case x of Inl (tls, s') ⇒ Some s' | Inr _ ⇒ None) tlsstlss"
proof -
let ?terminal = "λs tls. case terminal tls of
None ⇒ Inr (SOME tls'. trsys.inf_step silent_move2 s tls')
| Some s' ⇒ let tls' = SOME tls'. silent_moves2 s tls' s' in Inl (tls', s')"
let ?P = "λs tls (tls'', s', s''). silent_moves2 s tls'' s' ∧ s' -thd tls→ s'' ∧ ¬ τmove s' (thd tls) s'' ∧ s'' ⇓ ttl tls"
define tlsstlss where "tlsstlss s tls = unfold_tllist
(λ(s, tls). is_TNil tls)
(λ(s, tls). ?terminal s tls)
(λ(s, tls). let (tls'', s', s'') = Eps (?P s tls) in (tls'', s', thd tls, s''))
(λ(s, tls). let (tls'', s', s'') = Eps (?P s tls) in (s'', ttl tls))
(s, tls)"
for s tls
have [simp]:
"⋀s tls. is_TNil (tlsstlss s tls) ⟷ is_TNil tls"
"⋀s tls. is_TNil tls ⟹ terminal (tlsstlss s tls) = ?terminal s tls"
"⋀s tls. ¬ is_TNil tls ⟹ thd (tlsstlss s tls) = (let (tls'', s', s'') = Eps (?P s tls) in (tls'', s', thd tls, s''))"
"⋀s tls. ¬ is_TNil tls ⟹ ttl (tlsstlss s tls) = (let (tls'', s', s'') = Eps (?P s tls) in tlsstlss s'' (ttl tls))"
by(simp_all add: tlsstlss_def split_beta)
have [simp]:
"⋀s. tlsstlss s (TNil None) = TNil (Inr (SOME tls'. trsys.inf_step silent_move2 s tls'))"
"⋀s s'. tlsstlss s (TNil (Some s')) = TNil (Inl (SOME tls'. silent_moves2 s tls' s', s'))"
unfolding tlsstlss_def by simp_all
let ?conv = "tmap (λ(tls, s', tl, s''). tl) (λx. case x of Inl (tls, s') ⇒ Some s' | Inr _ ⇒ None)"
from assms have "τRuns_table2 s (tlsstlss s tls)"
proof(coinduction arbitrary: s tls)
case (τRuns_table2 s tls)
thus ?case
proof(cases)
case (Terminate s')
let ?P = "λtls'. silent_moves2 s tls' s'"
from ‹s -τ→* s'› obtain tls' where "?P tls'" by(blast dest: silent_moves_into_silent_moves2)
hence "?P (Eps ?P)" by(rule someI)
with Terminate have ?Terminate by auto
thus ?thesis by simp
next
case Diverge
let ?P = "λtls'. trsys.inf_step silent_move2 s tls'"
from ‹s -τ→ ∞› obtain tls' where "?P tls'" by(rule τdiverge_into_inf_step_silent_move2)
hence "?P (Eps ?P)" by(rule someI)
hence ?Diverge using ‹tls = TNil None› by simp
thus ?thesis by simp
next
case (Proceed s' s'' tls' tl)
from ‹s -τ→* s'› obtain tls'' where "silent_moves2 s tls'' s'"
by(blast dest: silent_moves_into_silent_moves2)
with Proceed have "?P s tls (tls'', s', s'')" by simp
hence "?P s tls (Eps (?P s tls))" by(rule someI)
hence ?Proceed using Proceed unfolding tlsstlss_def
by(subst unfold_tllist.code)(auto simp add: split_def)
thus ?thesis by simp
qed
qed
moreover
from assms have "tls = ?conv (tlsstlss s tls)"
proof(coinduction arbitrary: s tls)
case (Eq_tllist s tls)
thus ?case
proof(cases)
case (Proceed s' s'' tls' tl)
from ‹s -τ→* s'› obtain tls'' where "silent_moves2 s tls'' s'"
by(blast dest: silent_moves_into_silent_moves2)
with Proceed have "?P s tls (tls'', s', s'')" by simp
hence "?P s tls (Eps (?P s tls))" by(rule someI)
thus ?thesis using ‹tls = TCons tl tls'› by auto
qed auto
qed
ultimately show thesis by(rule that)
qed
lemma τRuns_table2_into_Runs:
assumes "τRuns_table2 s tlsstlss"
shows "Runs s (lconcat (lappend (lmap (λ(tls, s, tl, s'). llist_of (tls @ [tl])) (llist_of_tllist tlsstlss)) (LCons (case terminal tlsstlss of Inl (tls, s') ⇒ llist_of tls | Inr tls ⇒ tls) LNil)))"
(is "Runs _ (?conv tlsstlss)")
using assms
proof(coinduction arbitrary: s tlsstlss)
case (Runs s tlsstlss)
thus ?case
proof(cases)
case (Terminate tls' s')
from ‹silent_moves2 s tls' s'› show ?thesis
proof(cases rule: rtrancl3p_converseE)
case refl
hence ?Stuck using Terminate by simp
thus ?thesis ..
next
case (step tls'' tl s'')
from ‹silent_moves2 s'' tls'' s'› ‹⋀tl s''. ¬ s' -tl→ s''›
have "τRuns_table2 s'' (TNil (Inl (tls'', s')))" ..
with ‹tls' = tl # tls''› ‹silent_move2 s tl s''› ‹tlsstlss = TNil (Inl (tls', s'))›
have ?Step by(auto simp add: silent_move2_def intro!: exI)
thus ?thesis ..
qed
next
case (Diverge tls')
from ‹trsys.inf_step silent_move2 s tls'›
obtain tl tls'' s' where "silent_move2 s tl s'"
and "tls' = LCons tl tls''" "trsys.inf_step silent_move2 s' tls''"
by(cases rule: trsys.inf_step.cases[consumes 1]) auto
from ‹trsys.inf_step silent_move2 s' tls''›
have "τRuns_table2 s' (TNil (Inr tls''))" ..
hence ?Step using ‹tlsstlss = TNil (Inr tls')› ‹tls' = LCons tl tls''› ‹silent_move2 s tl s'›
by(auto simp add: silent_move2_def intro!: exI)
thus ?thesis ..
next
case (Proceed tls' s' s'' tlsstlss' tl)
from ‹silent_moves2 s tls' s'› have ?Step
proof(cases rule: rtrancl3p_converseE)
case refl with Proceed show ?thesis by auto
next
case (step tls'' tl' s''')
from ‹silent_moves2 s''' tls'' s'› ‹s' -tl→ s''› ‹¬ τmove s' tl s''› ‹τRuns_table2 s'' tlsstlss'›
have "τRuns_table2 s''' (TCons (tls'', s', tl, s'') tlsstlss')" ..
with ‹tls' = tl' # tls''› ‹silent_move2 s tl' s'''› ‹tlsstlss = TCons (tls', s', tl, s'') tlsstlss'›
show ?thesis by(auto simp add: silent_move2_def intro!: exI)
qed
thus ?thesis ..
qed
qed
lemma τRuns_table2_silentsD:
fixes tl
assumes Runs: "τRuns_table2 s tlsstlss"
and tset: "(tls, s', tl', s'') ∈ tset tlsstlss"
and set: "tl ∈ set tls"
shows "∃s''' s''''. silent_move2 s''' tl s''''"
using tset Runs
proof(induct arbitrary: s rule: tset_induct)
case (find tlsstlss')
from ‹τRuns_table2 s (TCons (tls, s', tl', s'') tlsstlss')›
have "silent_moves2 s tls s'" by cases
thus ?case using set by induct auto
next
case step thus ?case by(auto simp add: τRuns_table2_simps)
qed
lemma τRuns_table2_terminal_silentsD:
assumes Runs: "τRuns_table2 s tlsstlss"
and fin: "lfinite (llist_of_tllist tlsstlss)"
and terminal: "terminal tlsstlss = Inl (tls, s'')"
shows "∃s'. silent_moves2 s' tls s''"
using fin Runs terminal
proof(induct "llist_of_tllist tlsstlss" arbitrary: tlsstlss s)
case lfinite_LNil thus ?case
by(cases tlsstlss)(auto simp add: τRuns_table2_simps)
next
case (lfinite_LConsI xs tlsstls)
thus ?case by(cases tlsstlss)(auto simp add: τRuns_table2_simps)
qed
lemma τRuns_table2_terminal_inf_stepD:
assumes Runs: "τRuns_table2 s tlsstlss"
and fin: "lfinite (llist_of_tllist tlsstlss)"
and terminal: "terminal tlsstlss = Inr tls"
shows "∃s'. trsys.inf_step silent_move2 s' tls"
using fin Runs terminal
proof(induct "llist_of_tllist tlsstlss" arbitrary: s tlsstlss)
case lfinite_LNil thus ?case
by(cases tlsstlss)(auto simp add: τRuns_table2_simps)
next
case (lfinite_LConsI xs tlsstls)
thus ?case by(cases tlsstlss)(auto simp add: τRuns_table2_simps)
qed
lemma τRuns_table2_lappendtD:
assumes Runs: "τRuns_table2 s (lappendt tlsstlss tlsstlss')"
and fin: "lfinite tlsstlss"
shows "∃s'. τRuns_table2 s' tlsstlss'"
using fin Runs
by(induct arbitrary: s)(auto simp add: τRuns_table2_simps)
end
lemma τmoves_False: "τtrsys.silent_move r (λs ta s'. False) = (λs s'. False)"
by(auto simp add: τtrsys.silent_move_iff)
lemma τrtrancl3p_False_eq_rtrancl3p: "τtrsys.τrtrancl3p r (λs tl s'. False) = rtrancl3p r"
proof(intro ext iffI)
fix s tls s'
assume "τtrsys.τrtrancl3p r (λs tl s'. False) s tls s'"
thus "rtrancl3p r s tls s'" by(rule τtrsys.τrtrancl3p.induct)(blast intro: rtrancl3p_step_converse)+
next
fix s tls s'
assume "rtrancl3p r s tls s'"
thus "τtrsys.τrtrancl3p r (λs tl s'. False) s tls s'"
by(induct rule: rtrancl3p_converse_induct)(auto intro: τtrsys.τrtrancl3p.intros)
qed
lemma τdiverge_empty_τmove:
"τtrsys.τdiverge r (λs ta s'. False) = (λs. False)"
by(auto intro!: ext elim: τtrsys.τdiverge.cases τtrsys.silent_move.cases)
end
Theory FWLTS
section ‹The multithreaded semantics as a labelled transition system›
theory FWLTS
imports
FWProgressAux
FWLifting
LTS
begin
sublocale multithreaded_base < trsys "r t" for t .
sublocale multithreaded_base < mthr: trsys redT .
definition redT_upd_ε :: "('l,'t,'x,'m,'w) state ⇒ 't ⇒ 'x ⇒ 'm ⇒ ('l,'t,'x,'m,'w) state"
where [simp]: "redT_upd_ε s t x' m' = (locks s, ((thr s)(t ↦ (x', snd (the (thr s t)))), m'), wset s, interrupts s)"
lemma redT_upd_ε_redT_upd:
"redT_upd s t ε x' m' (redT_upd_ε s t x' m')"
by(auto simp add: redT_updLns_def redT_updWs_def)
context multithreaded begin
sublocale trsys "r t" for t .
sublocale mthr: trsys redT .
end
subsection ‹The multithreaded semantics with internal actions›
type_synonym
('l,'t,'x,'m,'w,'o) τmoves =
"'x × 'm ⇒ ('l,'t,'x,'m,'w,'o) thread_action ⇒ 'x × 'm ⇒ bool"
text ‹pretty printing for ‹τmoves››
print_translation ‹
let
fun tr' [(Const (@{type_syntax "prod"}, _) $ x1 $ m1),
(Const (@{type_syntax "fun"}, _) $
(Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax "finfun"}, _) $ l $
(Const (@{type_syntax "list"}, _) $ Const (@{type_syntax "lock_action"}, _))) $
(Const (@{type_syntax "prod"},_) $
(Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "new_thread_action"}, _) $ t1 $ x2 $ m2)) $
(Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "conditional_action"}, _) $ t2)) $
(Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "wait_set_action"}, _) $ t3 $ w)) $
(Const (@{type_syntax prod}, _) $
(Const (@{type_syntax list}, _) $ (Const (@{type_syntax "interrupt_action"}, _) $ t4)) $
(Const (@{type_syntax "list"}, _) $ o1)))))) $
(Const (@{type_syntax "fun"}, _) $
(Const (@{type_syntax "prod"}, _) $ x3 $ m3) $
(Const (@{type_syntax "bool"}, _))))] =
if x1 = x2 andalso x1 = x3 andalso m1 = m2 andalso m1 = m3 andalso t1 = t2 andalso t2 = t3 andalso t3 = t4
then Syntax.const (@{type_syntax "τmoves"}) $ l $ t1 $ x1 $ m1 $ w $ o1
else raise Match;
in [(@{type_syntax "fun"}, K tr')]
end
›
typ "('l,'t,'x,'m,'w,'o) τmoves"
locale τmultithreaded = multithreaded_base +
constrains final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics"
and convert_RA :: "'l released_locks ⇒ 'o list"
fixes τmove :: "('l,'t,'x,'m,'w,'o) τmoves"
sublocale τmultithreaded < τtrsys "r t" τmove for t .
context τmultithreaded begin
inductive mτmove :: "(('l,'t,'x,'m,'w) state, 't × ('l,'t,'x,'m,'w,'o) thread_action) trsys"
where
"⟦ thr s t = ⌊(x, no_wait_locks)⌋; thr s' t = ⌊(x', ln')⌋; τmove (x, shr s) ta (x', shr s') ⟧
⟹ mτmove s (t, ta) s'"
end
sublocale τmultithreaded < mthr: τtrsys redT mτmove .
context τmultithreaded begin
abbreviation τmredT :: "('l,'t,'x,'m,'w) state ⇒ ('l,'t,'x,'m,'w) state ⇒ bool"
where "τmredT == mthr.silent_move"
end
lemma (in multithreaded_base) τrtrancl3p_redT_thread_not_disappear:
assumes "τtrsys.τrtrancl3p redT τmove s ttas s'" "thr s t ≠ None"
shows "thr s' t ≠ None"
proof -
interpret T: τtrsys redT τmove .
show ?thesis
proof
assume "thr s' t = None"
with ‹τtrsys.τrtrancl3p redT τmove s ttas s'› have "thr s t = None"
by(induct rule: T.τrtrancl3p.induct)(auto simp add: split_paired_all dest: redT_thread_not_disappear)
with ‹thr s t ≠ None› show False by contradiction
qed
qed
lemma mτmove_False: "τmultithreaded.mτmove (λs ta s'. False) = (λs ta s'. False)"
by(auto intro!: ext elim: τmultithreaded.mτmove.cases)
declare split_paired_Ex [simp del]
locale τmultithreaded_wf =
τmultithreaded _ _ _ τmove +
multithreaded final r convert_RA
for τmove :: "('l,'t,'x,'m,'w,'o) τmoves" +
assumes τmove_heap: "⟦ t ⊢ (x, m) -ta→ (x', m'); τmove (x, m) ta (x', m') ⟧ ⟹ m = m'"
assumes silent_tl: "τmove s ta s' ⟹ ta = ε"
begin
lemma mτmove_silentD: "mτmove s (t, ta) s' ⟹ ta = (K$ [], [], [], [], [], [])"
by(auto elim!: mτmove.cases dest: silent_tl)
lemma mτmove_heap:
assumes redT: "redT s (t, ta) s'"
and mτmove: "mτmove s (t, ta) s'"
shows "shr s' = shr s"
using mτmove redT
by cases(auto dest: τmove_heap elim!: redT.cases)
lemma τmredT_thread_preserved:
"τmredT s s' ⟹ thr s t = None ⟷ thr s' t = None"
by(auto simp add: mthr.silent_move_iff elim!: redT.cases dest!: mτmove_silentD split: if_split_asm)
lemma τmRedT_thread_preserved:
"τmredT^** s s' ⟹ thr s t = None ⟷ thr s' t = None"
by(induct rule: rtranclp.induct)(auto dest: τmredT_thread_preserved[where t=t])
lemma τmtRedT_thread_preserved:
"τmredT^++ s s' ⟹ thr s t = None ⟷ thr s' t = None"
by(induct rule: tranclp.induct)(auto dest: τmredT_thread_preserved[where t=t])
lemma τmredT_add_thread_inv:
assumes τred: "τmredT s s'" and tst: "thr s t = None"
shows "τmredT (locks s, ((thr s)(t ↦ xln), shr s), wset s, interrupts s) (locks s', ((thr s')(t ↦ xln), shr s'), wset s', interrupts s')"
proof -
obtain ls ts m ws "is" where s: "s = (ls, (ts, m), ws, is)" by(cases s) fastforce
obtain ls' ts' m' ws' is' where s': "s' = (ls', (ts', m'), ws', is')" by(cases s') fastforce
from τred s s' obtain t' where red: "(ls, (ts, m), ws, is) -t'▹ε→ (ls', (ts', m'), ws', is')"
and τ: "mτmove (ls, (ts, m), ws, is) (t', ε) (ls', (ts', m'), ws', is')"
by(auto simp add: mthr.silent_move_iff dest: mτmove_silentD)
from red have "(ls, (ts(t ↦ xln), m), ws, is) -t'▹ε→ (ls', (ts'(t ↦ xln), m'), ws', is')"
proof(cases rule: redT_elims)
case (normal x x' m') with tst s show ?thesis
by-(rule redT_normal, auto simp add: fun_upd_twist elim!: rtrancl3p_cases)
next
case (acquire x ln n)
with tst s show ?thesis
unfolding ‹ε = (K$ [], [], [], [], [], convert_RA ln)›
by -(rule redT_acquire, auto intro: fun_upd_twist)
qed
moreover from red tst s have tt': "t ≠ t'" by(cases) auto
have "(λt''. (ts(t ↦ xln)) t'' ≠ None ∧ (ts(t ↦ xln)) t'' ≠ (ts'(t ↦ xln)) t'') =
(λt''. ts t'' ≠ None ∧ ts t'' ≠ ts' t'')" using tst s by(auto simp add: fun_eq_iff)
with τ tst tt' have "mτmove (ls, (ts(t ↦ xln), m), ws, is) (t', ε) (ls', (ts'(t ↦ xln), m'), ws', is')"
by cases(rule mτmove.intros, auto)
ultimately show ?thesis unfolding s s' by auto
qed
lemma τmRedT_add_thread_inv:
"⟦ τmredT^** s s'; thr s t = None ⟧
⟹ τmredT^** (locks s, ((thr s)(t ↦ xln), shr s), wset s, interrupts s) (locks s', ((thr s')(t ↦ xln), shr s'), wset s', interrupts s')"
apply(induct rule: rtranclp_induct)
apply(blast dest: τmRedT_thread_preserved[where t=t] τmredT_add_thread_inv[where xln=xln] intro: rtranclp.rtrancl_into_rtrancl)+
done
lemma τmtRed_add_thread_inv:
"⟦ τmredT^++ s s'; thr s t = None ⟧
⟹ τmredT^++ (locks s, ((thr s)(t ↦ xln), shr s), wset s, interrupts s) (locks s', ((thr s')(t ↦ xln), shr s'), wset s', interrupts s')"
apply(induct rule: tranclp_induct)
apply(blast dest: τmtRedT_thread_preserved[where t=t] τmredT_add_thread_inv[where xln=xln] intro: tranclp.trancl_into_trancl)+
done
lemma silent_move_into_RedT_τ_inv:
assumes move: "silent_move t (x, shr s) (x', m')"
and state: "thr s t = ⌊(x, no_wait_locks)⌋" "wset s t = None"
shows "τmredT s (redT_upd_ε s t x' m')"
proof -
from move obtain red: "t ⊢ (x, shr s) -ε→ (x', m')" and τ: "τmove (x, shr s) ε (x', m')"
by(auto simp add: silent_move_iff dest: silent_tl)
from red state have "s -t▹ε→ redT_upd_ε s t x' m'"
by -(rule redT_normal, auto simp add: redT_updLns_def o_def finfun_Diag_const2 redT_updWs_def)
moreover from τ red state have "mτmove s (t, ε) (redT_upd_ε s t x' m')"
by -(rule mτmove.intros, auto dest: τmove_heap simp add: redT_updLns_def)
ultimately show ?thesis by auto
qed
lemma silent_moves_into_RedT_τ_inv:
assumes major: "silent_moves t (x, shr s) (x', m')"
and state: "thr s t = ⌊(x, no_wait_locks)⌋" "wset s t = None"
shows "τmredT^** s (redT_upd_ε s t x' m')"
using major
proof(induct rule: rtranclp_induct2)
case refl with state show ?case by(cases s)(auto simp add: fun_upd_idem)
next
case (step x' m' x'' m'')
from ‹silent_move t (x', m') (x'', m'')› state
have "τmredT (redT_upd_ε s t x' m') (redT_upd_ε (redT_upd_ε s t x' m') t x'' m'')"
by -(rule silent_move_into_RedT_τ_inv, auto)
hence "τmredT (redT_upd_ε s t x' m') (redT_upd_ε s t x'' m'')" by(simp)
with ‹τmredT^** s (redT_upd_ε s t x' m')› show ?case ..
qed
lemma red_rtrancl_τ_heapD_inv:
"⟦ silent_moves t s s'; wfs t s ⟧ ⟹ snd s' = snd s"
proof(induct rule: rtranclp_induct)
case base show ?case ..
next
case (step s' s'')
thus ?case by(cases s, cases s', cases s'')(auto dest: τmove_heap)
qed
lemma red_trancl_τ_heapD_inv:
"⟦ silent_movet t s s'; wfs t s ⟧ ⟹ snd s' = snd s"
proof(induct rule: tranclp_induct)
case (base s') thus ?case by(cases s')(cases s, auto simp add: silent_move_iff dest: τmove_heap)
next
case (step s' s'')
thus ?case by(cases s, cases s', cases s'')(auto simp add: silent_move_iff dest: τmove_heap)
qed
lemma red_trancl_τ_into_RedT_τ_inv:
assumes major: "silent_movet t (x, shr s) (x', m')"
and state: "thr s t = ⌊(x, no_wait_locks)⌋" "wset s t = None"
shows "τmredT^++ s (redT_upd_ε s t x' m')"
using major
proof(induct rule: tranclp_induct2)
case (base x' m')
thus ?case using state
by -(rule tranclp.r_into_trancl, rule silent_move_into_RedT_τ_inv, auto)
next
case (step x' m' x'' m'')
hence "τmredT^++ s (redT_upd_ε s t x' m')" by blast
moreover from ‹silent_move t (x', m') (x'', m'')› state
have "τmredT (redT_upd_ε s t x' m') (redT_upd_ε (redT_upd_ε s t x' m') t x'' m'')"
by -(rule silent_move_into_RedT_τ_inv, auto simp add: redT_updLns_def)
hence "τmredT (redT_upd_ε s t x' m') (redT_upd_ε s t x'' m'')"
by(simp add: redT_updLns_def)
ultimately show ?case ..
qed
lemma τdiverge_into_τmredT:
assumes "τdiverge t (x, shr s)"
and "thr s t = ⌊(x, no_wait_locks)⌋" "wset s t = None"
shows "mthr.τdiverge s"
using assms
proof(coinduction arbitrary: s x)
case (τdiverge s x)
note tst = ‹thr s t = ⌊(x, no_wait_locks)⌋›
from ‹τdiverge t (x, shr s)› obtain x' m' where "silent_move t (x, shr s) (x', m')"
and "τdiverge t (x', m')" by cases auto
from ‹silent_move t (x, shr s) (x', m')› tst ‹wset s t = None›
have "τmredT s (redT_upd_ε s t x' m')" by(rule silent_move_into_RedT_τ_inv)
moreover have "thr (redT_upd_ε s t x' m') t = ⌊(x', no_wait_locks)⌋"
using tst by(auto simp add: redT_updLns_def)
moreover have "wset (redT_upd_ε s t x' m') t = None" using ‹wset s t = None› by simp
moreover from ‹τdiverge t (x', m')› have "τdiverge t (x', shr (redT_upd_ε s t x' m'))" by simp
ultimately show ?case using ‹τdiverge t (x', m')› by blast
qed
lemma τdiverge_τmredTD:
assumes div: "mthr.τdiverge s"
and fin: "finite (dom (thr s))"
shows "∃t x. thr s t = ⌊(x, no_wait_locks)⌋ ∧ wset s t = None ∧ τdiverge t (x, shr s)"
using fin div
proof(induct A≡"dom (thr s)" arbitrary: s rule: finite_induct)
case empty
from ‹mthr.τdiverge s› obtain s' where "τmredT s s'" by cases auto
with ‹{} = dom (thr s)›[symmetric] have False by(auto elim!: mthr.silent_move.cases redT.cases)
thus ?case ..
next
case (insert t A)
note IH = ‹⋀s. ⟦ A = dom (thr s); mthr.τdiverge s ⟧
⟹ ∃t x. thr s t = ⌊(x, no_wait_locks)⌋ ∧ wset s t = None ∧ τdiverge t (x, shr s)›
from ‹insert t A = dom (thr s)›
obtain x ln where tst: "thr s t = ⌊(x, ln)⌋" by(fastforce simp add: dom_def)
define s' where "s' = (locks s, ((thr s)(t := None), shr s), wset s, interrupts s)"
show ?case
proof(cases "ln = no_wait_locks ∧ τdiverge t (x, shr s) ∧ wset s t = None")
case True
with tst show ?thesis by blast
next
case False
define xm where "xm = (x, shr s)"
define xm' where "xm' = (x, shr s)"
have "A = dom (thr s')" using ‹t ∉ A› ‹insert t A = dom (thr s)›
unfolding s'_def by auto
moreover {
from xm'_def tst ‹mthr.τdiverge s› False
have "∃s x. thr s t = ⌊(x, ln)⌋ ∧ (ln ≠ no_wait_locks ∨ wset s t ≠ None ∨ ¬ τdiverge t xm') ∧
s' = (locks s, ((thr s)(t := None), shr s), wset s, interrupts s) ∧ xm = (x, shr s) ∧
mthr.τdiverge s ∧ silent_moves t xm' xm"
unfolding s'_def xm_def by blast
moreover
from False have "wfP (if τdiverge t xm' then (λs s'. False) else flip (silent_move_from t xm'))"
using τdiverge_neq_wfP_silent_move_from[of t "(x, shr s)"] unfolding xm'_def by(auto)
ultimately have "mthr.τdiverge s'"
proof(coinduct s' xm rule: mthr.τdiverge_trancl_measure_coinduct)
case (τdiverge s' xm)
then obtain s x where tst: "thr s t = ⌊(x, ln)⌋"
and blocked: "ln ≠ no_wait_locks ∨ wset s t ≠ None ∨ ¬ τdiverge t xm'"
and s'_def: "s' = (locks s, ((thr s)(t := None), shr s), wset s, interrupts s)"
and xm_def: "xm = (x, shr s)"
and xmxm': "silent_moves t xm' (x, shr s)"
and "mthr.τdiverge s" by blast
from ‹mthr.τdiverge s› obtain s'' where "τmredT s s''" "mthr.τdiverge s''" by cases auto
from ‹τmredT s s''› obtain t' ta where "s -t'▹ta→ s''" and "mτmove s (t', ta) s''" by auto
then obtain x' x'' m'' where red: "t' ⊢ ⟨x', shr s⟩ -ta→ ⟨x'', m''⟩"
and tst': "thr s t' = ⌊(x', no_wait_locks)⌋"
and aoe: "actions_ok s t' ta"
and s'': "redT_upd s t' ta x'' m'' s''"
by cases(fastforce elim: mτmove.cases)+
from ‹mτmove s (t', ta) s''› have [simp]: "ta = ε"
by(auto elim!: mτmove.cases dest!: silent_tl)
hence wst': "wset s t' = None" using aoe by auto
from ‹mτmove s (t', ta) s''› tst' s''
have "τmove (x', shr s) ε (x'', m'')" by(auto elim: mτmove.cases)
show ?case
proof(cases "t' = t")
case False
with tst' wst' have "thr s' t' = ⌊(x', no_wait_locks)⌋"
"wset s' t' = None" "shr s' = shr s" unfolding s'_def by auto
with red have "s' -t'▹ε→ redT_upd_ε s' t' x'' m''"
by -(rule redT_normal, auto simp add: redT_updLns_def o_def finfun_Diag_const2 redT_updWs_def)
moreover from ‹τmove (x', shr s) ε (x'', m'')› ‹thr s' t' = ⌊(x', no_wait_locks)⌋› ‹shr s' = shr s›
have "mτmove s' (t', ta) (redT_upd_ε s' t' x'' m'')"
by -(rule mτmove.intros, auto)
ultimately have "τmredT s' (redT_upd_ε s' t' x'' m'')"
unfolding ‹ta = ε› by(rule mthr.silent_move.intros)
hence "τmredT^++ s' (redT_upd_ε s' t' x'' m'')" ..
moreover have "thr s'' t = ⌊(x, ln)⌋"
using tst ‹t' ≠ t› s'' by auto
moreover from ‹τmove (x', shr s) ε (x'', m'')› red
have [simp]: "m'' = shr s" by(auto dest: τmove_heap)
hence "shr s = shr s''" using s'' by(auto)
have "ln ≠ no_wait_locks ∨ wset s'' t ≠ None ∨ ¬ τdiverge t xm'"
using blocked s'' by(auto simp add: redT_updWs_def elim!: rtrancl3p_cases)
moreover have "redT_upd_ε s' t' x'' m'' = (locks s'', ((thr s'')(t := None), shr s''), wset s'', interrupts s'')"
unfolding s'_def using tst s'' ‹t' ≠ t›
by(auto intro: ext elim!: rtrancl3p_cases simp add: redT_updLns_def redT_updWs_def)
ultimately show ?thesis using ‹mthr.τdiverge s''› xmxm'
unfolding ‹shr s = shr s''› by blast
next
case True
with tst tst' wst' blocked have "¬ τdiverge t xm'"
and [simp]: "x' = x" by auto
moreover from red ‹τmove (x', shr s) ε (x'', m'')› True
have "silent_move t (x, shr s) (x'', m'')" by auto
with xmxm' have "silent_move_from t xm' (x, shr s) (x'', m'')"
by(rule silent_move_fromI)
ultimately have "(if τdiverge t xm' then λs s'. False else flip (silent_move_from t xm')) (x'', m'') xm"
by(auto simp add: flip_conv xm_def)
moreover have "thr s'' t = ⌊(x'', ln)⌋" using tst True s''
by(auto simp add: redT_updLns_def)
moreover from ‹τmove (x', shr s) ε (x'', m'')› red
have [simp]: "m'' = shr s" by(auto dest: τmove_heap)
hence "shr s = shr s''" using s'' by auto
have "s' = (locks s'', ((thr s'')(t := None), shr s''), wset s'', interrupts s'')"
using True s'' unfolding s'_def
by(auto intro: ext elim!: rtrancl3p_cases simp add: redT_updLns_def redT_updWs_def)
moreover have "(x'', m'') = (x'', shr s'')" using s'' by auto
moreover from xmxm' ‹silent_move t (x, shr s) (x'', m'')›
have "silent_moves t xm' (x'', shr s'')"
unfolding ‹m'' = shr s› ‹shr s = shr s''› by auto
ultimately show ?thesis using ‹¬ τdiverge t xm'› ‹mthr.τdiverge s''› by blast
qed
qed }
ultimately have "∃t x. thr s' t = ⌊(x, no_wait_locks)⌋ ∧ wset s' t = None ∧ τdiverge t (x, shr s')" by(rule IH)
then obtain t' x' where "thr s' t' = ⌊(x', no_wait_locks)⌋"
and "wset s' t' = None" and "τdiverge t' (x', shr s')" by blast
moreover with False have "t' ≠ t" by(auto simp add: s'_def)
ultimately have "thr s t' = ⌊(x', no_wait_locks)⌋" "wset s t' = None" "τdiverge t' (x', shr s)"
unfolding s'_def by auto
thus ?thesis by blast
qed
qed
lemma τmredT_preserves_final_thread:
"⟦ τmredT s s'; final_thread s t ⟧ ⟹ final_thread s' t"
by(auto elim: mthr.silent_move.cases intro: redT_preserves_final_thread)
lemma τmRedT_preserves_final_thread:
"⟦ τmredT^** s s'; final_thread s t ⟧ ⟹ final_thread s' t"
by(induct rule: rtranclp.induct)(blast intro: τmredT_preserves_final_thread)+
lemma silent_moves2_silentD:
assumes "rtrancl3p mthr.silent_move2 s ttas s'"
and "(t, ta) ∈ set ttas"
shows "ta = ε"
using assms
by(induct)(auto simp add: mthr.silent_move2_def dest: mτmove_silentD)
lemma inf_step_silentD:
assumes step: "trsys.inf_step mthr.silent_move2 s ttas"
and lset: "(t, ta) ∈ lset ttas"
shows "ta = ε"
using lset step
by(induct arbitrary: s rule: lset_induct)(fastforce elim: trsys.inf_step.cases simp add: mthr.silent_move2_def dest: mτmove_silentD)+
end
subsection ‹The multithreaded semantics with a well-founded relation on states›
locale multithreaded_base_measure = multithreaded_base +
constrains final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics"
and convert_RA :: "'l released_locks ⇒ 'o list"
fixes μ :: "('x × 'm) ⇒ ('x × 'm) ⇒ bool"
begin
inductive mμt :: "'m ⇒ ('l,'t,'x) thread_info ⇒ ('l,'t,'x) thread_info ⇒ bool"
for m and ts and ts'
where
mμtI:
"⋀ln. ⟦ finite (dom ts); ts t = ⌊(x, ln)⌋; ts' t = ⌊(x', ln')⌋; μ (x, m) (x', m); ⋀t'. t' ≠ t ⟹ ts t' = ts' t' ⟧
⟹ mμt m ts ts'"
definition mμ :: "('l,'t,'x,'m,'w) state ⇒ ('l,'t,'x,'m,'w) state ⇒ bool"
where "mμ s s' ⟷ shr s = shr s' ∧ mμt (shr s) (thr s) (thr s')"
lemma mμt_thr_dom_eq: "mμt m ts ts' ⟹ dom ts = dom ts'"
apply(erule mμt.cases)
apply(rule equalityI)
apply(rule subsetI)
apply(case_tac "xa = t")
apply(auto)[2]
apply(rule subsetI)
apply(case_tac "xa = t")
apply auto
done
lemma mμ_finite_thrD:
assumes "mμt m ts ts'"
shows "finite (dom ts)" "finite (dom ts')"
using assms
by(simp_all add: mμt_thr_dom_eq[symmetric])(auto elim: mμt.cases)
end
locale multithreaded_base_measure_wf = multithreaded_base_measure +
constrains final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics"
and convert_RA :: "'l released_locks ⇒ 'o list"
and μ :: "('x × 'm) ⇒ ('x × 'm) ⇒ bool"
assumes wf_μ: "wfP μ"
begin
lemma wf_mμt: "wfP (mμt m)"
unfolding wfP_eq_minimal
proof(intro strip)
fix Q :: "('l,'t,'x) thread_info set" and ts
assume "ts ∈ Q"
show "∃z∈Q. ∀y. mμt m y z ⟶ y ∉ Q"
proof(cases "finite (dom ts)")
case False
hence "∀y. mμt m y ts ⟶ y ∉ Q" by(auto dest: mμ_finite_thrD)
thus ?thesis using ‹ts ∈ Q› by blast
next
case True
thus ?thesis using ‹ts ∈ Q›
proof(induct A≡"dom ts" arbitrary: ts Q rule: finite_induct)
case empty
hence "dom ts = {}" by simp
with ‹ts ∈ Q› show ?case by(auto elim: mμt.cases)
next
case (insert t A)
note IH = ‹⋀ts Q. ⟦A = dom ts; ts ∈ Q⟧ ⟹ ∃z∈Q. ∀y. mμt m y z ⟶ y ∉ Q›
define Q' where "Q' = {ts. ts t = None ∧ (∃xln. ts(t ↦ xln) ∈ Q)}"
let ?ts' = "ts(t := None)"
from ‹insert t A = dom ts› ‹t ∉ A› have "A = dom ?ts'" by auto
moreover from ‹insert t A = dom ts› obtain xln where "ts t = ⌊xln⌋" by(cases "ts t") auto
hence "ts(t ↦ xln) = ts" by(auto simp add: fun_eq_iff)
with ‹ts ∈ Q› have "ts(t ↦ xln) ∈ Q" by(auto)
hence "?ts' ∈ Q'" unfolding Q'_def by(auto simp del: split_paired_Ex)
ultimately have "∃z∈Q'. ∀y. mμt m y z ⟶ y ∉ Q'" by(rule IH)
then obtain ts' where "ts' ∈ Q'"
and min: "⋀ts''. mμt m ts'' ts' ⟹ ts'' ∉ Q'" by blast
from ‹ts' ∈ Q'› obtain x' ln' where "ts' t = None" "ts'(t ↦ (x', ln')) ∈ Q"
unfolding Q'_def by auto
define Q'' where "Q'' = {(x, m)|x. ∃ln. ts'(t ↦ (x, ln)) ∈ Q}"
from ‹ts'(t ↦ (x', ln')) ∈ Q› have "(x', m) ∈ Q''" unfolding Q''_def by blast
hence "∃xm''∈Q''. ∀xm'''. μ xm''' xm'' ⟶ xm''' ∉ Q''" by(rule wf_μ[unfolded wfP_eq_minimal, rule_format])
then obtain xm'' where "xm'' ∈ Q''" and min': "⋀xm'''. μ xm''' xm'' ⟹ xm''' ∉ Q''" by blast
from ‹xm'' ∈ Q''› obtain x'' ln'' where "xm'' = (x'', m)" "ts'(t ↦ (x'', ln'')) ∈ Q" unfolding Q''_def by blast
moreover {
fix ts''
assume "mμt m ts'' (ts'(t ↦ (x'', ln'')))"
then obtain T X'' LN'' X' LN'
where "finite (dom ts'')" "ts'' T = ⌊(X'', LN'')⌋"
and "(ts'(t ↦ (x'', ln''))) T = ⌊(X', LN')⌋" "μ (X'', m) (X', m)"
and eq: "⋀t'. t' ≠ T ⟹ ts'' t' = (ts'(t ↦ (x'', ln''))) t'" by(cases) blast
have "ts'' ∉ Q"
proof(cases "T = t")
case True
from True ‹(ts'(t ↦ (x'', ln''))) T = ⌊(X', LN')⌋› have "X' = x''" by simp
with ‹μ (X'', m) (X', m)› have "(X'', m) ∉ Q''" by(auto dest: min'[unfolded ‹xm'' = (x'', m)›])
hence "∀ln. ts'(t ↦ (X'', ln)) ∉ Q" by(simp add: Q''_def)
moreover from ‹ts' t = None› eq True
have "ts''(t := None) = ts'" by(auto simp add: fun_eq_iff)
with ‹ts'' T = ⌊(X'', LN'')⌋› True
have ts'': "ts'' = ts'(t ↦ (X'', LN''))" by(auto intro!: ext)
ultimately show ?thesis by blast
next
case False
from ‹finite (dom ts'')› have "finite (dom (ts''(t := None)))" by simp
moreover from ‹ts'' T = ⌊(X'', LN'')⌋› False
have "(ts''(t := None)) T = ⌊(X'', LN'')⌋" by simp
moreover from ‹(ts'(t ↦ (x'', ln''))) T = ⌊(X', LN')⌋› False
have "ts' T = ⌊(X', LN')⌋" by simp
ultimately have "mμt m (ts''(t := None)) ts'" using ‹μ (X'', m) (X', m)›
proof(rule mμtI)
fix t'
assume "t' ≠ T"
with eq[OF False[symmetric]] eq[OF this] ‹ts' t = None›
show "(ts''(t := None)) t' = ts' t'" by auto
qed
hence "ts''(t := None) ∉ Q'" by(rule min)
thus ?thesis
proof(rule contrapos_nn)
assume "ts'' ∈ Q"
from eq[OF False[symmetric]] have "ts'' t = ⌊(x'', ln'')⌋" by simp
hence ts'': "ts''(t ↦ (x'', ln'')) = ts''" by(auto simp add: fun_eq_iff)
from ‹ts'' ∈ Q› have "ts''(t ↦ (x'', ln'')) ∈ Q" unfolding ts'' .
thus "ts''(t := None) ∈ Q'" unfolding Q'_def by auto
qed
qed
}
ultimately show ?case by blast
qed
qed
qed
lemma wf_mμ: "wfP mμ"
proof -
have "wf (inv_image (same_fst (λm. True) (λm. {(ts, ts'). mμt m ts ts'})) (λs. (shr s, thr s)))"
by(rule wf_inv_image)(rule wf_same_fst, rule wf_mμt[unfolded wfP_def])
also have "inv_image (same_fst (λm. True) (λm. {(ts, ts'). mμt m ts ts'})) (λs. (shr s, thr s)) = {(s, s'). mμ s s'}"
by(auto simp add: mμ_def same_fst_def)
finally show ?thesis by(simp add: wfP_def)
qed
end
end
Theory Bisimulation
section ‹Various notions of bisimulation›
theory Bisimulation
imports
LTS
begin
type_synonym ('a, 'b) bisim = "'a ⇒ 'b ⇒ bool"
subsection ‹Strong bisimulation›
locale bisimulation_base = r1: trsys trsys1 + r2: trsys trsys2
for trsys1 :: "('s1, 'tl1) trsys" ("_/ -1-_→/ _" [50,0,50] 60)
and trsys2 :: "('s2, 'tl2) trsys" ("_/ -2-_→/ _" [50,0,50] 60) +
fixes bisim :: "('s1, 's2) bisim" ("_/ ≈ _" [50, 50] 60)
and tlsim :: "('tl1, 'tl2) bisim" ("_/ ∼ _" [50, 50] 60)
begin
notation
r1.Trsys ("_/ -1-_→*/ _" [50,0,50] 60) and
r2.Trsys ("_/ -2-_→*/ _" [50,0,50] 60)
notation
r1.inf_step ("_ -1-_→* ∞" [50, 0] 80) and
r2.inf_step ("_ -2-_→* ∞" [50, 0] 80)
notation
r1.inf_step_table ("_ -1-_→*t ∞" [50, 0] 80) and
r2.inf_step_table ("_ -2-_→*t ∞" [50, 0] 80)
abbreviation Tlsim :: "('tl1 list, 'tl2 list) bisim" ("_/ [∼] _" [50, 50] 60)
where "Tlsim tl1 tl2 ≡ list_all2 tlsim tl1 tl2"
abbreviation Tlsiml :: "('tl1 llist, 'tl2 llist) bisim" ("_/ [[∼]] _" [50, 50] 60)
where "Tlsiml tl1 tl2 ≡ llist_all2 tlsim tl1 tl2"
end
locale bisimulation = bisimulation_base +
constrains trsys1 :: "('s1, 'tl1) trsys"
and trsys2 :: "('s2, 'tl2) trsys"
and bisim :: "('s1, 's2) bisim"
and tlsim :: "('tl1, 'tl2) bisim"
assumes simulation1: "⟦ s1 ≈ s2; s1 -1-tl1→ s1' ⟧ ⟹ ∃s2' tl2. s2 -2-tl2→ s2' ∧ s1' ≈ s2' ∧ tl1 ∼ tl2"
and simulation2: "⟦ s1 ≈ s2; s2 -2-tl2→ s2' ⟧ ⟹ ∃s1' tl1. s1 -1-tl1→ s1' ∧ s1' ≈ s2' ∧ tl1 ∼ tl2"
begin
lemma bisimulation_flip:
"bisimulation trsys2 trsys1 (flip bisim) (flip tlsim)"
by(unfold_locales)(unfold flip_simps,(blast intro: simulation1 simulation2)+)
end
lemma bisimulation_flip_simps [flip_simps]:
"bisimulation trsys2 trsys1 (flip bisim) (flip tlsim) = bisimulation trsys1 trsys2 bisim tlsim"
by(auto dest: bisimulation.bisimulation_flip simp only: flip_flip)
context bisimulation begin
lemma simulation1_rtrancl:
"⟦s1 -1-tls1→* s1'; s1 ≈ s2⟧
⟹ ∃s2' tls2. s2 -2-tls2→* s2' ∧ s1' ≈ s2' ∧ tls1 [∼] tls2"
proof(induct rule: rtrancl3p.induct)
case rtrancl3p_refl thus ?case by(auto intro: rtrancl3p.rtrancl3p_refl)
next
case (rtrancl3p_step s1 tls1 s1' tl1 s1'')
from ‹s1 ≈ s2 ⟹ ∃s2' tls2. s2 -2-tls2→* s2' ∧ s1' ≈ s2' ∧ tls1 [∼] tls2› ‹s1 ≈ s2›
obtain s2' tls2 where "s2 -2-tls2→* s2'" "s1' ≈ s2'" "tls1 [∼] tls2" by blast
moreover from ‹s1' -1-tl1→ s1''› ‹s1' ≈ s2'›
obtain s2'' tl2 where "s2' -2-tl2→ s2''" "s1'' ≈ s2''" "tl1 ∼ tl2" by(auto dest: simulation1)
ultimately have "s2 -2-tls2 @ [tl2]→* s2''" "tls1 @ [tl1] [∼] tls2 @ [tl2]"
by(auto intro: rtrancl3p.rtrancl3p_step list_all2_appendI)
with ‹s1'' ≈ s2''› show ?case by(blast)
qed
lemma simulation2_rtrancl:
"⟦s2 -2-tls2→* s2'; s1 ≈ s2⟧
⟹ ∃s1' tls1. s1 -1-tls1→* s1' ∧ s1' ≈ s2' ∧ tls1 [∼] tls2"
using bisimulation.simulation1_rtrancl[OF bisimulation_flip]
unfolding flip_simps .
lemma simulation1_inf_step:
assumes red1: "s1 -1-tls1→* ∞" and bisim: "s1 ≈ s2"
shows "∃tls2. s2 -2-tls2→* ∞ ∧ tls1 [[∼]] tls2"
proof -
from r1.inf_step_imp_inf_step_table[OF red1]
obtain stls1 where red1': "s1 -1-stls1→*t ∞"
and tls1: "tls1 = lmap (fst ∘ snd) stls1" by blast
define tl1_to_tl2 where "tl1_to_tl2 s2 stls1 = unfold_llist
(λ(s2, stls1). lnull stls1)
(λ(s2, stls1). let (s1, tl1, s1') = lhd stls1;
(tl2, s2') = SOME (tl2, s2'). trsys2 s2 tl2 s2' ∧ s1' ≈ s2' ∧ tl1 ∼ tl2
in (s2, tl2, s2'))
(λ(s2, stls1). let (s1, tl1, s1') = lhd stls1;
(tl2, s2') = SOME (tl2, s2'). trsys2 s2 tl2 s2' ∧ s1' ≈ s2' ∧ tl1 ∼ tl2
in (s2', ltl stls1))
(s2, stls1)"
for s2 :: 's2 and stls1 :: "('s1 × 'tl1 × 's1) llist"
have tl1_to_tl2_simps [simp]:
"⋀s2 stls1. lnull (tl1_to_tl2 s2 stls1) ⟷ lnull stls1"
"⋀s2 stls1. ¬ lnull stls1 ⟹ lhd (tl1_to_tl2 s2 stls1) =
(let (s1, tl1, s1') = lhd stls1;
(tl2, s2') = SOME (tl2, s2'). trsys2 s2 tl2 s2' ∧ s1' ≈ s2' ∧ tl1 ∼ tl2
in (s2, tl2, s2'))"
"⋀s2 stls1. ¬ lnull stls1 ⟹ ltl (tl1_to_tl2 s2 stls1) =
(let (s1, tl1, s1') = lhd stls1;
(tl2, s2') = SOME (tl2, s2'). trsys2 s2 tl2 s2' ∧ s1' ≈ s2' ∧ tl1 ∼ tl2
in tl1_to_tl2 s2' (ltl stls1))"
"⋀s2. tl1_to_tl2 s2 LNil = LNil"
"⋀s2 s1 tl1 s1' stls1'. tl1_to_tl2 s2 (LCons (s1, tl1, s1') stls1') =
LCons (s2, SOME (tl2, s2'). trsys2 s2 tl2 s2' ∧ s1' ≈ s2' ∧ tl1 ∼ tl2)
(tl1_to_tl2 (snd (SOME (tl2, s2'). trsys2 s2 tl2 s2' ∧ s1' ≈ s2' ∧ tl1 ∼ tl2)) stls1')"
by(simp_all add: tl1_to_tl2_def split_beta)
have [simp]: "llength (tl1_to_tl2 s2 stls1) = llength stls1"
by(coinduction arbitrary: s2 stls1 rule: enat_coinduct)(auto simp add: epred_llength split_beta)
from red1' bisim have "s2 -2-tl1_to_tl2 s2 stls1→*t ∞"
proof(coinduction arbitrary: s2 s1 stls1)
case (inf_step_table s2 s1 stls1)
note red1' = ‹s1 -1-stls1→*t ∞› and bisim = ‹s1 ≈ s2›
from red1' show ?case
proof(cases)
case (inf_step_tableI s1' stls1' tl1)
hence stls1: "stls1 = LCons (s1, tl1, s1') stls1'"
and r: "s1 -1-tl1→ s1'" and reds1: "s1' -1-stls1'→*t ∞" by simp_all
let ?tl2s2' = "SOME (tl2, s2'). s2 -2-tl2→ s2' ∧ s1' ≈ s2' ∧ tl1 ∼ tl2"
let ?tl2 = "fst ?tl2s2'" let ?s2' = "snd ?tl2s2'"
from simulation1[OF bisim r] obtain s2' tl2
where "s2 -2-tl2→ s2'" "s1' ≈ s2'" "tl1 ∼ tl2" by blast
hence "(λ(tl2, s2'). s2 -2-tl2→ s2' ∧ s1' ≈ s2' ∧ tl1 ∼ tl2) (tl2, s2')" by simp
hence "(λ(tl2, s2'). s2 -2-tl2→ s2' ∧ s1' ≈ s2' ∧ tl1 ∼ tl2) ?tl2s2'" by(rule someI)
hence "s2 -2-?tl2→ ?s2'" "s1' ≈ ?s2'" "tl1 ∼ ?tl2" by(simp_all add: split_beta)
then show ?thesis using reds1 stls1 by(fastforce intro: prod_eqI)
qed
qed
hence "s2 -2-lmap (fst ∘ snd) (tl1_to_tl2 s2 stls1)→* ∞"
by(rule r2.inf_step_table_imp_inf_step)
moreover have "tls1 [[∼]] lmap (fst ∘ snd) (tl1_to_tl2 s2 stls1)"
proof(rule llist_all2_all_lnthI)
show "llength tls1 = llength (lmap (fst ∘ snd) (tl1_to_tl2 s2 stls1))"
using tls1 by simp
next
fix n
assume "enat n < llength tls1"
thus "lnth tls1 n ∼ lnth (lmap (fst ∘ snd) (tl1_to_tl2 s2 stls1)) n"
using red1' bisim unfolding tls1
proof(induct n arbitrary: s1 s2 stls1 rule: nat_less_induct)
case (1 n)
hence IH: "⋀m s1 s2 stls1. ⟦ m < n; enat m < llength (lmap (fst ∘ snd) stls1);
s1 -1-stls1→*t ∞; s1 ≈ s2 ⟧
⟹ lnth (lmap (fst ∘ snd) stls1) m ∼ lnth (lmap (fst ∘ snd) (tl1_to_tl2 s2 stls1)) m"
by blast
from ‹s1 -1-stls1→*t ∞› show ?case
proof cases
case (inf_step_tableI s1' stls1' tl1)
hence stls1: "stls1 = LCons (s1, tl1, s1') stls1'"
and r: "s1 -1-tl1→ s1'" and reds: "s1' -1-stls1'→*t ∞" by simp_all
let ?tl2s2' = "SOME (tl2, s2'). s2 -2-tl2→ s2' ∧ s1' ≈ s2' ∧ tl1 ∼ tl2"
let ?tl2 = "fst ?tl2s2'" let ?s2' = "snd ?tl2s2'"
from simulation1[OF ‹s1 ≈ s2› r] obtain s2' tl2
where "s2 -2-tl2→ s2' ∧ s1' ≈ s2' ∧ tl1 ∼ tl2" by blast
hence "(λ(tl2, s2'). s2 -2-tl2→ s2' ∧ s1' ≈ s2' ∧ tl1 ∼ tl2) (tl2, s2')" by simp
hence "(λ(tl2, s2'). s2 -2-tl2→ s2' ∧ s1' ≈ s2' ∧ tl1 ∼ tl2) ?tl2s2'" by(rule someI)
hence bisim': "s1' ≈ ?s2'" and tlsim: "tl1 ∼ ?tl2" by(simp_all add: split_beta)
show ?thesis
proof(cases n)
case 0
with stls1 tlsim show ?thesis by simp
next
case (Suc m)
hence "m < n" by simp
moreover have "enat m < llength (lmap (fst ∘ snd) stls1')"
using stls1 ‹enat n < llength (lmap (fst ∘ snd) stls1)› Suc by(simp add: Suc_ile_eq)
ultimately have "lnth (lmap (fst ∘ snd) stls1') m ∼ lnth (lmap (fst ∘ snd) (tl1_to_tl2 ?s2' stls1')) m"
using reds bisim' by(rule IH)
with Suc stls1 show ?thesis by(simp del: o_apply)
qed
qed
qed
qed
ultimately show ?thesis by blast
qed
lemma simulation2_inf_step:
"⟦ s2 -2-tls2→* ∞; s1 ≈ s2 ⟧ ⟹ ∃tls1. s1 -1-tls1→* ∞ ∧ tls1 [[∼]] tls2"
using bisimulation.simulation1_inf_step[OF bisimulation_flip]
unfolding flip_simps .
end
locale bisimulation_final_base =
bisimulation_base +
constrains trsys1 :: "('s1, 'tl1) trsys"
and trsys2 :: "('s2, 'tl2) trsys"
and bisim :: "('s1, 's2) bisim"
and tlsim :: "('tl1, 'tl2) bisim"
fixes final1 :: "'s1 ⇒ bool"
and final2 :: "'s2 ⇒ bool"
locale bisimulation_final = bisimulation_final_base + bisimulation +
constrains trsys1 :: "('s1, 'tl1) trsys"
and trsys2 :: "('s2, 'tl2) trsys"
and bisim :: "('s1, 's2) bisim"
and tlsim :: "('tl1, 'tl2) bisim"
and final1 :: "'s1 ⇒ bool"
and final2 :: "'s2 ⇒ bool"
assumes bisim_final: "s1 ≈ s2 ⟹ final1 s1 ⟷ final2 s2"
begin
lemma bisimulation_final_flip:
"bisimulation_final trsys2 trsys1 (flip bisim) (flip tlsim) final2 final1"
apply(intro_locales)
apply(rule bisimulation_flip)
apply(unfold_locales)
by(unfold flip_simps, rule bisim_final[symmetric])
end
lemma bisimulation_final_flip_simps [flip_simps]:
"bisimulation_final trsys2 trsys1 (flip bisim) (flip tlsim) final2 final1 =
bisimulation_final trsys1 trsys2 bisim tlsim final1 final2"
by(auto dest: bisimulation_final.bisimulation_final_flip simp only: flip_flip)
context bisimulation_final begin
lemma final_simulation1:
"⟦ s1 ≈ s2; s1 -1-tls1→* s1'; final1 s1' ⟧
⟹ ∃s2' tls2. s2 -2-tls2→* s2' ∧ s1' ≈ s2' ∧ final2 s2' ∧ tls1 [∼] tls2"
by(auto dest: bisim_final dest!: simulation1_rtrancl)
lemma final_simulation2:
"⟦ s1 ≈ s2; s2 -2-tls2→* s2'; final2 s2' ⟧
⟹ ∃s1' tls1. s1 -1-tls1→* s1' ∧ s1' ≈ s2' ∧ final1 s1' ∧ tls1 [∼] tls2"
by(auto dest: bisim_final dest!: simulation2_rtrancl)
end
subsection ‹Delay bisimulation›
locale delay_bisimulation_base =
bisimulation_base +
trsys1?: τtrsys trsys1 τmove1 +
trsys2?: τtrsys trsys2 τmove2
for τmove1 τmove2 +
constrains trsys1 :: "('s1, 'tl1) trsys"
and trsys2 :: "('s2, 'tl2) trsys"
and bisim :: "('s1, 's2) bisim"
and tlsim :: "('tl1, 'tl2) bisim"
and τmove1 :: "('s1, 'tl1) trsys"
and τmove2 :: "('s2, 'tl2) trsys"
begin
notation
trsys1.silent_move ("_/ -τ1→ _" [50, 50] 60) and
trsys2.silent_move ("_/ -τ2→ _" [50, 50] 60)
notation
trsys1.silent_moves ("_/ -τ1→* _" [50, 50] 60) and
trsys2.silent_moves ("_/ -τ2→* _" [50, 50] 60)
notation
trsys1.silent_movet ("_/ -τ1→+ _" [50, 50] 60) and
trsys2.silent_movet ("_/ -τ2→+ _" [50, 50] 60)
notation
trsys1.τrtrancl3p ("_ -τ1-_→* _" [50, 0, 50] 60) and
trsys2.τrtrancl3p ("_ -τ2-_→* _" [50, 0, 50] 60)
notation
trsys1.τinf_step ("_ -τ1-_→* ∞" [50, 0] 80) and
trsys2.τinf_step ("_ -τ2-_→* ∞" [50, 0] 80)
notation
trsys1.τdiverge ("_ -τ1→ ∞" [50] 80) and
trsys2.τdiverge ("_ -τ2→ ∞" [50] 80)
notation
trsys1.τinf_step_table ("_ -τ1-_→*t ∞" [50, 0] 80) and
trsys2.τinf_step_table ("_ -τ2-_→*t ∞" [50, 0] 80)
notation
trsys1.τRuns ("_ ⇓1 _" [50, 50] 51) and
trsys2.τRuns ("_ ⇓2 _" [50, 50] 51)
lemma simulation_silent1I':
assumes "∃s2'. (if μ1 s1' s1 then trsys2.silent_moves else trsys2.silent_movet) s2 s2' ∧ s1' ≈ s2'"
shows "s1' ≈ s2 ∧ μ1^++ s1' s1 ∨ (∃s2'. s2 -τ2→+ s2' ∧ s1' ≈ s2')"
proof -
from assms obtain s2' where red: "(if μ1 s1' s1 then trsys2.silent_moves else trsys2.silent_movet) s2 s2'"
and bisim: "s1' ≈ s2'" by blast
show ?thesis
proof(cases "μ1 s1' s1")
case True
with red have "s2 -τ2→* s2'" by simp
thus ?thesis using bisim True by cases(blast intro: rtranclp_into_tranclp1)+
next
case False
with red bisim show ?thesis by auto
qed
qed
lemma simulation_silent2I':
assumes "∃s1'. (if μ2 s2' s2 then trsys1.silent_moves else trsys1.silent_movet) s1 s1' ∧ s1' ≈ s2'"
shows "s1 ≈ s2' ∧ μ2^++ s2' s2 ∨ (∃s1'. s1 -τ1→+ s1' ∧ s1' ≈ s2')"
using assms
by(rule delay_bisimulation_base.simulation_silent1I')
end
locale delay_bisimulation_obs = delay_bisimulation_base _ _ _ _ τmove1 τmove2
for τmove1 :: "'s1 ⇒ 'tl1 ⇒ 's1 ⇒ bool"
and τmove2 :: "'s2 ⇒ 'tl2 ⇒ 's2 ⇒ bool" +
assumes simulation1:
"⟦ s1 ≈ s2; s1 -1-tl1→ s1'; ¬ τmove1 s1 tl1 s1' ⟧
⟹ ∃s2' s2'' tl2. s2 -τ2→* s2' ∧ s2' -2-tl2→ s2'' ∧ ¬ τmove2 s2' tl2 s2'' ∧ s1' ≈ s2'' ∧ tl1 ∼ tl2"
and simulation2:
"⟦ s1 ≈ s2; s2 -2-tl2→ s2'; ¬ τmove2 s2 tl2 s2' ⟧
⟹ ∃s1' s1'' tl1. s1 -τ1→* s1' ∧ s1' -1-tl1→ s1'' ∧ ¬ τmove1 s1' tl1 s1'' ∧ s1'' ≈ s2' ∧ tl1 ∼ tl2"
begin
lemma delay_bisimulation_obs_flip: "delay_bisimulation_obs trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1"
apply(unfold_locales)
apply(unfold flip_simps)
by(blast intro: simulation1 simulation2)+
end
lemma delay_bisimulation_obs_flip_simps [flip_simps]:
"delay_bisimulation_obs trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 =
delay_bisimulation_obs trsys1 trsys2 bisim tlsim τmove1 τmove2"
by(auto dest: delay_bisimulation_obs.delay_bisimulation_obs_flip simp only: flip_flip)
locale delay_bisimulation_diverge = delay_bisimulation_obs _ _ _ _ τmove1 τmove2
for τmove1 :: "'s1 ⇒ 'tl1 ⇒ 's1 ⇒ bool"
and τmove2 :: "'s2 ⇒ 'tl2 ⇒ 's2 ⇒ bool" +
assumes simulation_silent1:
"⟦ s1 ≈ s2; s1 -τ1→ s1' ⟧ ⟹ ∃s2'. s2 -τ2→* s2' ∧ s1' ≈ s2'"
and simulation_silent2:
"⟦ s1 ≈ s2; s2 -τ2→ s2' ⟧ ⟹ ∃s1'. s1 -τ1→* s1' ∧ s1' ≈ s2'"
and τdiverge_bisim_inv: "s1 ≈ s2 ⟹ s1 -τ1→ ∞ ⟷ s2 -τ2→ ∞"
begin
lemma delay_bisimulation_diverge_flip: "delay_bisimulation_diverge trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1"
apply(rule delay_bisimulation_diverge.intro)
apply(rule delay_bisimulation_obs_flip)
apply(unfold_locales)
apply(unfold flip_simps)
by(blast intro: simulation_silent1 simulation_silent2 τdiverge_bisim_inv[symmetric] del: iffI)+
end
lemma delay_bisimulation_diverge_flip_simps [flip_simps]:
"delay_bisimulation_diverge trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 =
delay_bisimulation_diverge trsys1 trsys2 bisim tlsim τmove1 τmove2"
by(auto dest: delay_bisimulation_diverge.delay_bisimulation_diverge_flip simp only: flip_flip)
context delay_bisimulation_diverge begin
lemma simulation_silents1:
assumes bisim: "s1 ≈ s2" and moves: "s1 -τ1→* s1'"
shows "∃s2'. s2 -τ2→* s2' ∧ s1' ≈ s2'"
using moves bisim
proof induct
case base thus ?case by(blast)
next
case (step s1' s1'')
from ‹s1 ≈ s2 ⟹ ∃s2'. s2 -τ2→* s2' ∧ s1' ≈ s2'› ‹s1 ≈ s2›
obtain s2' where "s2 -τ2→* s2'" "s1' ≈ s2'" by blast
from simulation_silent1[OF ‹s1' ≈ s2'› ‹s1' -τ1→ s1''›]
obtain s2'' where "s2' -τ2→* s2''" "s1'' ≈ s2''" by blast
from ‹s2 -τ2→* s2'› ‹s2' -τ2→* s2''› have "s2 -τ2→* s2''" by(rule rtranclp_trans)
with ‹s1'' ≈ s2''› show ?case by blast
qed
lemma simulation_silents2:
"⟦ s1 ≈ s2; s2 -τ2→* s2' ⟧ ⟹ ∃s1'. s1 -τ1→* s1' ∧ s1' ≈ s2'"
using delay_bisimulation_diverge.simulation_silents1[OF delay_bisimulation_diverge_flip]
unfolding flip_simps .
lemma simulation1_τrtrancl3p:
"⟦ s1 -τ1-tls1→* s1'; s1 ≈ s2 ⟧
⟹ ∃tls2 s2'. s2 -τ2-tls2→* s2' ∧ s1' ≈ s2' ∧ tls1 [∼] tls2"
proof(induct arbitrary: s2 rule: trsys1.τrtrancl3p.induct)
case (τrtrancl3p_refl s)
thus ?case by(auto intro: τtrsys.τrtrancl3p.intros)
next
case (τrtrancl3p_step s1 s1' tls1 s1'' tl1)
from simulation1[OF ‹s1 ≈ s2› ‹s1 -1-tl1→ s1'› ‹¬ τmove1 s1 tl1 s1'›]
obtain s2' s2'' tl2 where τred: "s2 -τ2→* s2'"
and red: "s2' -2-tl2→ s2''" and nτ: "¬ τmove2 s2' tl2 s2''"
and bisim': "s1' ≈ s2''" and tlsim: "tl1 ∼ tl2" by blast
from bisim' ‹s1' ≈ s2'' ⟹ ∃tls2 s2'. s2'' -τ2-tls2→* s2' ∧ s1'' ≈ s2' ∧ tls1 [∼] tls2›
obtain tls2 s2''' where IH: "s2'' -τ2-tls2→* s2'''" "s1'' ≈ s2'''" "tls1 [∼] tls2" by blast
from τred have "s2 -τ2-[]→* s2'" by(rule trsys2.silent_moves_into_τrtrancl3p)
also from red nτ IH(1) have "s2' -τ2-tl2 # tls2→* s2'''" by(rule τrtrancl3p.τrtrancl3p_step)
finally show ?case using IH tlsim by fastforce
next
case (τrtrancl3p_τstep s1 s1' tls1 s1'' tl1)
from ‹s1 -1-tl1→ s1'› ‹τmove1 s1 tl1 s1'› have "s1 -τ1→ s1'" ..
from simulation_silent1[OF ‹s1 ≈ s2› this]
obtain s2' where τred: "s2 -τ2→* s2'" and bisim': "s1' ≈ s2'" by blast
from τred have "s2 -τ2-[]→* s2'" by(rule trsys2.silent_moves_into_τrtrancl3p)
also from bisim' ‹s1' ≈ s2' ⟹ ∃tls2 s2''. s2' -τ2-tls2→* s2'' ∧ s1'' ≈ s2'' ∧ tls1 [∼] tls2›
obtain tls2 s2'' where IH: "s2' -τ2-tls2→* s2''" "s1'' ≈ s2''" "tls1 [∼] tls2" by blast
note ‹s2' -τ2-tls2→* s2''›
finally show ?case using IH by auto
qed
lemma simulation2_τrtrancl3p:
"⟦ s2 -τ2-tls2→* s2'; s1 ≈ s2 ⟧
⟹ ∃tls1 s1'. s1 -τ1-tls1→* s1' ∧ s1' ≈ s2' ∧ tls1 [∼] tls2"
using delay_bisimulation_diverge.simulation1_τrtrancl3p[OF delay_bisimulation_diverge_flip]
unfolding flip_simps .
lemma simulation1_τinf_step:
assumes τinf1: "s1 -τ1-tls1→* ∞" and bisim: "s1 ≈ s2"
shows "∃tls2. s2 -τ2-tls2→* ∞ ∧ tls1 [[∼]] tls2"
proof -
from trsys1.τinf_step_imp_τinf_step_table[OF τinf1]
obtain sstls1 where τinf1': "s1 -τ1-sstls1→*t ∞"
and tls1: "tls1 = lmap (fst ∘ snd ∘ snd) sstls1" by blast
define tl1_to_tl2 where "tl1_to_tl2 s2 sstls1 = unfold_llist
(λ(s2, sstls1). lnull sstls1)
(λ(s2, sstls1).
let (s1, s1', tl1, s1'') = lhd sstls1;
(s2', tl2, s2'') = SOME (s2', tl2, s2''). s2 -τ2→* s2' ∧ trsys2 s2' tl2 s2'' ∧
¬ τmove2 s2' tl2 s2'' ∧ s1'' ≈ s2'' ∧ tl1 ∼ tl2
in (s2, s2', tl2, s2''))
(λ(s2, sstls1).
let (s1, s1', tl1, s1'') = lhd sstls1;
(s2', tl2, s2'') = SOME (s2', tl2, s2''). s2 -τ2→* s2' ∧ trsys2 s2' tl2 s2'' ∧
¬ τmove2 s2' tl2 s2'' ∧ s1'' ≈ s2'' ∧ tl1 ∼ tl2
in (s2'', ltl sstls1))
(s2, sstls1)"
for s2 :: 's2 and sstls1 :: "('s1 × 's1 × 'tl1 × 's1) llist"
have [simp]:
"⋀s2 sstls1. lnull (tl1_to_tl2 s2 sstls1) ⟷ lnull sstls1"
"⋀s2 sstls1. ¬ lnull sstls1 ⟹ lhd (tl1_to_tl2 s2 sstls1) =
(let (s1, s1', tl1, s1'') = lhd sstls1;
(s2', tl2, s2'') = SOME (s2', tl2, s2''). s2 -τ2→* s2' ∧ trsys2 s2' tl2 s2'' ∧
¬ τmove2 s2' tl2 s2'' ∧ s1'' ≈ s2'' ∧ tl1 ∼ tl2
in (s2, s2', tl2, s2''))"
"⋀s2 sstls1. ¬ lnull sstls1 ⟹ ltl (tl1_to_tl2 s2 sstls1) =
(let (s1, s1', tl1, s1'') = lhd sstls1;
(s2', tl2, s2'') = SOME (s2', tl2, s2''). s2 -τ2→* s2' ∧ trsys2 s2' tl2 s2'' ∧
¬ τmove2 s2' tl2 s2'' ∧ s1'' ≈ s2'' ∧ tl1 ∼ tl2
in tl1_to_tl2 s2'' (ltl sstls1))"
"⋀s2. tl1_to_tl2 s2 LNil = LNil"
"⋀s2 s1 s1' tl1 s1'' stls1'. tl1_to_tl2 s2 (LCons (s1, s1', tl1, s1'') stls1') =
LCons (s2, SOME (s2', tl2, s2''). s2 -τ2→* s2' ∧ trsys2 s2' tl2 s2'' ∧
¬ τmove2 s2' tl2 s2'' ∧ s1'' ≈ s2'' ∧ tl1 ∼ tl2)
(tl1_to_tl2 (snd (snd (SOME (s2', tl2, s2''). s2 -τ2→* s2' ∧ trsys2 s2' tl2 s2'' ∧
¬ τmove2 s2' tl2 s2'' ∧ s1'' ≈ s2'' ∧ tl1 ∼ tl2)))
stls1')"
by(simp_all add: tl1_to_tl2_def split_beta)
have [simp]: "llength (tl1_to_tl2 s2 sstls1) = llength sstls1"
by(coinduction arbitrary: s2 sstls1 rule: enat_coinduct)(auto simp add: epred_llength split_beta)
define sstls2 where "sstls2 = tl1_to_tl2 s2 sstls1"
with τinf1' bisim have "∃s1 sstls1. s1 -τ1-sstls1→*t ∞ ∧ sstls2 = tl1_to_tl2 s2 sstls1 ∧ s1 ≈ s2" by blast
from τinf1' bisim have "s2 -τ2-tl1_to_tl2 s2 sstls1→*t ∞"
proof(coinduction arbitrary: s2 s1 sstls1)
case (τinf_step_table s2 s1 sstls1)
note τinf' = ‹s1 -τ1-sstls1→*t ∞› and bisim = ‹s1 ≈ s2›
from τinf' show ?case
proof(cases)
case (τinf_step_table_Cons s1' s1'' sstls1' tl1)
hence sstls1: "sstls1 = LCons (s1, s1', tl1, s1'') sstls1'"
and τs: "s1 -τ1→* s1'" and r: "s1' -1-tl1→ s1''" and nτ: "¬ τmove1 s1' tl1 s1''"
and reds1: "s1'' -τ1-sstls1'→*t ∞" by simp_all
let ?P = "λ(s2', tl2, s2''). s2 -τ2→* s2' ∧ trsys2 s2' tl2 s2'' ∧ ¬ τmove2 s2' tl2 s2'' ∧ s1'' ≈ s2'' ∧ tl1 ∼ tl2"
let ?s2tl2s2' = "Eps ?P"
let ?s2'' = "snd (snd ?s2tl2s2')"
from simulation_silents1[OF ‹s1 ≈ s2› τs]
obtain s2' where "s2 -τ2→* s2'" "s1' ≈ s2'" by blast
from simulation1[OF ‹s1' ≈ s2'› r nτ] obtain s2'' s2''' tl2
where "s2' -τ2→* s2''"
and rest: "s2'' -2-tl2→ s2'''" "¬ τmove2 s2'' tl2 s2'''" "s1'' ≈ s2'''" "tl1 ∼ tl2" by blast
from ‹s2 -τ2→* s2'› ‹s2' -τ2→* s2''› have "s2 -τ2→* s2''" by(rule rtranclp_trans)
with rest have "?P (s2'', tl2, s2''')" by simp
hence "?P ?s2tl2s2'" by(rule someI)
then show ?thesis using reds1 sstls1 by fastforce
next
case τinf_step_table_Nil
hence [simp]: "sstls1 = LNil" and "s1 -τ1→ ∞" by simp_all
from ‹s1 -τ1→ ∞› ‹s1 ≈ s2› have "s2 -τ2→ ∞" by(simp add: τdiverge_bisim_inv)
thus ?thesis using sstls2_def by simp
qed
qed
hence "s2 -τ2-lmap (fst ∘ snd ∘ snd) (tl1_to_tl2 s2 sstls1)→* ∞"
by(rule trsys2.τinf_step_table_into_τinf_step)
moreover have "tls1 [[∼]] lmap (fst ∘ snd ∘ snd) (tl1_to_tl2 s2 sstls1)"
proof(rule llist_all2_all_lnthI)
show "llength tls1 = llength (lmap (fst ∘ snd ∘ snd) (tl1_to_tl2 s2 sstls1))"
using tls1 by simp
next
fix n
assume "enat n < llength tls1"
thus "lnth tls1 n ∼ lnth (lmap (fst ∘ snd ∘ snd) (tl1_to_tl2 s2 sstls1)) n"
using τinf1' bisim unfolding tls1
proof(induct n arbitrary: s1 s2 sstls1 rule: less_induct)
case (less n)
note IH = ‹⋀m s1 s2 sstls1. ⟦ m < n; enat m < llength (lmap (fst ∘ snd ∘ snd) sstls1);
s1 -τ1-sstls1→*t ∞; s1 ≈ s2 ⟧
⟹ lnth (lmap (fst ∘ snd ∘ snd) sstls1) m ∼ lnth (lmap (fst ∘ snd ∘ snd) (tl1_to_tl2 s2 sstls1)) m›
from ‹s1 -τ1-sstls1→*t ∞› show ?case
proof cases
case (τinf_step_table_Cons s1' s1'' sstls1' tl1)
hence sstls1: "sstls1 = LCons (s1, s1', tl1, s1'') sstls1'"
and τs: "s1 -τ1→* s1'" and r: "s1' -1-tl1→ s1''"
and nτ: "¬ τmove1 s1' tl1 s1''" and reds: "s1'' -τ1-sstls1'→*t ∞" by simp_all
let ?P = "λ(s2', tl2, s2''). s2 -τ2→* s2' ∧ trsys2 s2' tl2 s2'' ∧ ¬ τmove2 s2' tl2 s2'' ∧ s1'' ≈ s2'' ∧ tl1 ∼ tl2"
let ?s2tl2s2' = "Eps ?P" let ?tl2 = "fst (snd ?s2tl2s2')" let ?s2'' = "snd (snd ?s2tl2s2')"
from simulation_silents1[OF ‹s1 ≈ s2› τs] obtain s2'
where "s2 -τ2→* s2'" "s1' ≈ s2'" by blast
from simulation1[OF ‹s1' ≈ s2'› r nτ] obtain s2'' s2''' tl2
where "s2' -τ2→* s2''"
and rest: "s2'' -2-tl2→ s2'''" "¬ τmove2 s2'' tl2 s2'''" "s1'' ≈ s2'''" "tl1 ∼ tl2" by blast
from ‹s2 -τ2→* s2'› ‹s2' -τ2→* s2''› have "s2 -τ2→* s2''" by(rule rtranclp_trans)
with rest have "?P (s2'', tl2, s2''')" by auto
hence "?P ?s2tl2s2'" by(rule someI)
hence "s1'' ≈ ?s2''" "tl1 ∼ ?tl2" by(simp_all add: split_beta)
show ?thesis
proof(cases n)
case 0
with sstls1 ‹tl1 ∼ ?tl2› show ?thesis by simp
next
case (Suc m)
hence "m < n" by simp
moreover have "enat m < llength (lmap (fst ∘ snd ∘ snd) sstls1')"
using sstls1 ‹enat n < llength (lmap (fst ∘ snd ∘ snd) sstls1)› Suc by(simp add: Suc_ile_eq)
ultimately have "lnth (lmap (fst ∘ snd ∘ snd) sstls1') m ∼ lnth (lmap (fst ∘ snd ∘ snd) (tl1_to_tl2 ?s2'' sstls1')) m"
using reds ‹s1'' ≈ ?s2''› by(rule IH)
with Suc sstls1 show ?thesis by(simp del: o_apply)
qed
next
case τinf_step_table_Nil
with ‹enat n < llength (lmap (fst ∘ snd ∘ snd) sstls1)› have False by simp
thus ?thesis ..
qed
qed
qed
ultimately show ?thesis by blast
qed
lemma simulation2_τinf_step:
"⟦ s2 -τ2-tls2→* ∞; s1 ≈ s2 ⟧ ⟹ ∃tls1. s1 -τ1-tls1→* ∞ ∧ tls1 [[∼]] tls2"
using delay_bisimulation_diverge.simulation1_τinf_step[OF delay_bisimulation_diverge_flip]
unfolding flip_simps .
lemma no_τmove1_τs_to_no_τmove2:
assumes "s1 ≈ s2"
and no_τmoves1: "⋀s1'. ¬ s1 -τ1→ s1'"
shows "∃s2'. s2 -τ2→* s2' ∧ (∀s2''. ¬ s2' -τ2→ s2'') ∧ s1 ≈ s2'"
proof -
have "¬ s1 -τ1→ ∞"
proof
assume "s1 -τ1→ ∞"
then obtain s1' where "s1 -τ1→ s1'" by cases
with no_τmoves1[of s1'] show False by contradiction
qed
with ‹s1 ≈ s2› have "¬ s2 -τ2→ ∞" by(simp add: τdiverge_bisim_inv)
from trsys2.not_τdiverge_to_no_τmove[OF this]
obtain s2' where "s2 -τ2→* s2'" and "⋀s2''. ¬ s2' -τ2→ s2''" by blast
moreover from simulation_silents2[OF ‹s1 ≈ s2› ‹s2 -τ2→* s2'›]
obtain s1' where "s1 -τ1→* s1'" and "s1' ≈ s2'" by blast
from ‹s1 -τ1→* s1'› no_τmoves1 have "s1' = s1"
by(auto elim: converse_rtranclpE)
ultimately show ?thesis using ‹s1' ≈ s2'› by blast
qed
lemma no_τmove2_τs_to_no_τmove1:
"⟦ s1 ≈ s2; ⋀s2'. ¬ s2 -τ2→ s2' ⟧ ⟹ ∃s1'. s1 -τ1→* s1' ∧ (∀s1''. ¬ s1' -τ1→ s1'') ∧ s1' ≈ s2"
using delay_bisimulation_diverge.no_τmove1_τs_to_no_τmove2[OF delay_bisimulation_diverge_flip]
unfolding flip_simps .
lemma no_move1_to_no_move2:
assumes "s1 ≈ s2"
and no_moves1: "⋀tl1 s1'. ¬ s1 -1-tl1→ s1'"
shows "∃s2'. s2 -τ2→* s2' ∧ (∀tl2 s2''. ¬ s2' -2-tl2→ s2'') ∧ s1 ≈ s2'"
proof -
from no_moves1 have "⋀s1'. ¬ s1 -τ1→ s1'" by(auto)
from no_τmove1_τs_to_no_τmove2[OF ‹s1 ≈ s2› this]
obtain s2' where "s2 -τ2→* s2'" and "s1 ≈ s2'"
and no_τmoves2: "⋀s2''. ¬ s2' -τ2→ s2''" by blast
moreover
have "⋀tl2 s2''. ¬ s2' -2-tl2→ s2''"
proof
fix tl2 s2''
assume "s2' -2-tl2→ s2''"
with no_τmoves2[of s2''] have "¬ τmove2 s2' tl2 s2''" by(auto)
from simulation2[OF ‹s1 ≈ s2'› ‹s2' -2-tl2→ s2''› this]
obtain s1' s1'' tl1 where "s1 -τ1→* s1'" and "s1' -1-tl1→ s1''" by blast
with no_moves1 show False by(fastforce elim: converse_rtranclpE)
qed
ultimately show ?thesis by blast
qed
lemma no_move2_to_no_move1:
"⟦ s1 ≈ s2; ⋀tl2 s2'. ¬ s2 -2-tl2→ s2' ⟧
⟹ ∃s1'. s1 -τ1→* s1' ∧ (∀tl1 s1''. ¬ s1' -1-tl1→ s1'') ∧ s1' ≈ s2"
using delay_bisimulation_diverge.no_move1_to_no_move2[OF delay_bisimulation_diverge_flip]
unfolding flip_simps .
lemma simulation_τRuns_table1:
assumes bisim: "s1 ≈ s2"
and run1: "trsys1.τRuns_table s1 stlsss1"
shows "∃stlsss2. trsys2.τRuns_table s2 stlsss2 ∧ tllist_all2 (λ(tl1, s1'') (tl2, s2''). tl1 ∼ tl2 ∧ s1'' ≈ s2'') (rel_option bisim) stlsss1 stlsss2"
proof(intro exI conjI)
let ?P = "λ(s2 :: 's2) (stlsss1 :: ('tl1 × 's1, 's1 option) tllist) (tl2, s2'').
∃s2'. s2 -τ2→* s2' ∧ s2' -2-tl2→ s2'' ∧ ¬ τmove2 s2' tl2 s2'' ∧ snd (thd stlsss1) ≈ s2'' ∧ fst (thd stlsss1) ∼ tl2"
define tls1_to_tls2 where "tls1_to_tls2 s2 stlsss1 = unfold_tllist
(λ(s2, stlsss1). is_TNil stlsss1)
(λ(s2, stlsss1). map_option (λs1'. SOME s2'. s2 -τ2→* s2' ∧ (∀tl s2''. ¬ s2' -2-tl→ s2'') ∧ s1' ≈ s2') (terminal stlsss1))
(λ(s2, stlsss1). let (tl2, s2'') = Eps (?P s2 stlsss1) in (tl2, s2''))
(λ(s2, stlsss1). let (tl2, s2'') = Eps (?P s2 stlsss1) in (s2'', ttl stlsss1))
(s2, stlsss1)"
for s2 stlsss1
have [simp]:
"⋀s2 stlsss1. is_TNil (tls1_to_tls2 s2 stlsss1) ⟷ is_TNil stlsss1"
"⋀s2 stlsss1. is_TNil stlsss1 ⟹ terminal (tls1_to_tls2 s2 stlsss1) = map_option (λs1'. SOME s2'. s2 -τ2→* s2' ∧ (∀tl s2''. ¬ s2' -2-tl→ s2'') ∧ s1' ≈ s2') (terminal stlsss1)"
"⋀s2 stlsss1. ¬ is_TNil stlsss1 ⟹ thd (tls1_to_tls2 s2 stlsss1) = (let (tl2, s2'') = Eps (?P s2 stlsss1) in (tl2, s2''))"
"⋀s2 stlsss1. ¬ is_TNil stlsss1 ⟹ ttl (tls1_to_tls2 s2 stlsss1) = (let (tl2, s2'') = Eps (?P s2 stlsss1) in tls1_to_tls2 s2'' (ttl stlsss1))"
"⋀s2 os1. tls1_to_tls2 s2 (TNil os1) =
TNil (map_option (λs1'. SOME s2'. s2 -τ2→* s2' ∧ (∀tl s2''. ¬ s2' -2-tl→ s2'') ∧ s1' ≈ s2') os1)"
by(simp_all add: tls1_to_tls2_def split_beta)
have [simp]:
"⋀s2 s1 s1' tl1 s1'' stlsss1.
tls1_to_tls2 s2 (TCons (tl1, s1'') stlsss1) =
(let (tl2, s2'') = SOME (tl2, s2''). ∃s2'. s2 -τ2→* s2' ∧ s2' -2-tl2→ s2'' ∧
¬ τmove2 s2' tl2 s2'' ∧ s1'' ≈ s2'' ∧ tl1 ∼ tl2
in TCons (tl2, s2'') (tls1_to_tls2 s2'' stlsss1))"
by(rule tllist.expand)(simp_all add: split_beta)
from bisim run1
show "trsys2.τRuns_table s2 (tls1_to_tls2 s2 stlsss1)"
proof(coinduction arbitrary: s2 s1 stlsss1)
case (τRuns_table s2 s1 stlsss1)
note bisim = ‹s1 ≈ s2›
and run1 = ‹trsys1.τRuns_table s1 stlsss1›
from run1 show ?case
proof cases
case (Terminate s1')
let ?P = "λs2'. s2 -τ2→* s2' ∧ (∀tl2 s2''. ¬ s2' -2-tl2→ s2'') ∧ s1' ≈ s2'"
from simulation_silents1[OF bisim ‹s1 -τ1→* s1'›]
obtain s2' where "s2 -τ2→* s2'" and "s1' ≈ s2'" by blast
moreover from no_move1_to_no_move2[OF ‹s1' ≈ s2'› ‹⋀tl1 s1''. ¬ s1' -1-tl1→ s1''›]
obtain s2'' where "s2' -τ2→* s2''" and "s1' ≈ s2''"
and "⋀tl2 s2'''. ¬ s2'' -2-tl2→ s2'''" by blast
ultimately have "?P s2''" by(blast intro: rtranclp_trans)
hence "?P (Eps ?P)" by(rule someI)
hence ?Terminate using ‹stlsss1 = TNil ⌊s1'⌋› by simp
thus ?thesis ..
next
case Diverge
with τdiverge_bisim_inv[OF bisim]
have ?Diverge by simp
thus ?thesis by simp
next
case (Proceed s1' s1'' stlsss1' tl1)
let ?P = "λ(tl2, s2''). ∃s2'. s2 -τ2→* s2' ∧ s2' -2-tl2→ s2'' ∧ ¬ τmove2 s2' tl2 s2'' ∧ s1'' ≈ s2'' ∧ tl1 ∼ tl2"
from simulation_silents1[OF bisim ‹s1 -τ1→* s1'›]
obtain s2' where "s2 -τ2→* s2'" and "s1' ≈ s2'" by blast
moreover from simulation1[OF ‹s1' ≈ s2'› ‹s1' -1-tl1→ s1''› ‹¬ τmove1 s1' tl1 s1''›]
obtain s2'' s2''' tl2 where "s2' -τ2→* s2''"
and "s2'' -2-tl2→ s2'''" and "¬ τmove2 s2'' tl2 s2'''"
and "s1'' ≈ s2'''" and "tl1 ∼ tl2" by blast
ultimately have "?P (tl2, s2''')" by(blast intro: rtranclp_trans)
hence "?P (Eps ?P)" by(rule someI)
hence ?Proceed
using ‹stlsss1 = TCons (tl1, s1'') stlsss1'› ‹trsys1.τRuns_table s1'' stlsss1'›
by auto blast
thus ?thesis by simp
qed
qed
let ?Tlsim = "λ(tl1, s1'') (tl2, s2''). tl1 ∼ tl2 ∧ s1'' ≈ s2''"
let ?Bisim = "rel_option bisim"
from run1 bisim
show "tllist_all2 ?Tlsim ?Bisim stlsss1 (tls1_to_tls2 s2 stlsss1)"
proof(coinduction arbitrary: s1 s2 stlsss1)
case (tllist_all2 s1 s2 stlsss1)
note Runs = ‹trsys1.τRuns_table s1 stlsss1› and bisim = ‹s1 ≈ s2›
from Runs show ?case
proof cases
case (Terminate s1')
let ?P = "λs2'. s2 -τ2→* s2' ∧ (∀tl2 s2''. ¬ s2' -2-tl2→ s2'') ∧ s1' ≈ s2'"
from simulation_silents1[OF bisim ‹s1 -τ1→* s1'›]
obtain s2' where "s2 -τ2→* s2'" and "s1' ≈ s2'" by blast
moreover
from no_move1_to_no_move2[OF ‹s1' ≈ s2'› ‹⋀tl1 s1''. ¬ s1' -1-tl1→ s1''›]
obtain s2'' where "s2' -τ2→* s2''" and "s1' ≈ s2''"
and "⋀tl2 s2'''. ¬ s2'' -2-tl2→ s2'''" by blast
ultimately have "?P s2''" by(blast intro: rtranclp_trans)
hence "?P (Eps ?P)" by(rule someI)
thus ?thesis using ‹stlsss1 = TNil ⌊s1'⌋› bisim by(simp)
next
case (Proceed s1' s1'' stlsss1' tl1)
from simulation_silents1[OF bisim ‹s1 -τ1→* s1'›]
obtain s2' where "s2 -τ2→* s2'" and "s1' ≈ s2'" by blast
moreover from simulation1[OF ‹s1' ≈ s2'› ‹s1' -1-tl1→ s1''› ‹¬ τmove1 s1' tl1 s1''›]
obtain s2'' s2''' tl2 where "s2' -τ2→* s2''"
and "s2'' -2-tl2→ s2'''" and "¬ τmove2 s2'' tl2 s2'''"
and "s1'' ≈ s2'''" and "tl1 ∼ tl2" by blast
ultimately have "?P s2 stlsss1 (tl2, s2''')"
using ‹stlsss1 = TCons (tl1, s1'') stlsss1'› by(auto intro: rtranclp_trans)
hence "?P s2 stlsss1 (Eps (?P s2 stlsss1))" by(rule someI)
thus ?thesis using ‹stlsss1 = TCons (tl1, s1'') stlsss1'› ‹trsys1.τRuns_table s1'' stlsss1'› bisim
by auto blast
qed simp
qed
qed
lemma simulation_τRuns_table2:
assumes "s1 ≈ s2"
and "trsys2.τRuns_table s2 stlsss2"
shows "∃stlsss1. trsys1.τRuns_table s1 stlsss1 ∧ tllist_all2 (λ(tl1, s1'') (tl2, s2''). tl1 ∼ tl2 ∧ s1'' ≈ s2'') (rel_option bisim) stlsss1 stlsss2"
using delay_bisimulation_diverge.simulation_τRuns_table1[OF delay_bisimulation_diverge_flip, unfolded flip_simps, OF assms]
by(subst tllist_all2_flip[symmetric])(simp only: flip_def split_def)
lemma simulation_τRuns1:
assumes bisim: "s1 ≈ s2"
and run1: "s1 ⇓1 tls1"
shows "∃tls2. s2 ⇓2 tls2 ∧ tllist_all2 tlsim (rel_option bisim) tls1 tls2"
proof -
from trsys1.τRuns_into_τRuns_table[OF run1]
obtain stlsss1 where tls1: "tls1 = tmap fst id stlsss1"
and τRuns1: "trsys1.τRuns_table s1 stlsss1" by blast
from simulation_τRuns_table1[OF bisim τRuns1]
obtain stlsss2 where τRuns2: "trsys2.τRuns_table s2 stlsss2"
and tlsim: "tllist_all2 (λ(tl1, s1'') (tl2, s2''). tl1 ∼ tl2 ∧ s1'' ≈ s2'')
(rel_option bisim) stlsss1 stlsss2" by blast
from τRuns2 have "s2 ⇓2 tmap fst id stlsss2"
by(rule τRuns_table_into_τRuns)
moreover have "tllist_all2 tlsim (rel_option bisim) tls1 (tmap fst id stlsss2)"
using tlsim unfolding tls1
by(fastforce simp add: tllist_all2_tmap1 tllist_all2_tmap2 elim: tllist_all2_mono rel_option_mono)
ultimately show ?thesis by blast
qed
lemma simulation_τRuns2:
"⟦ s1 ≈ s2; s2 ⇓2 tls2 ⟧
⟹ ∃tls1. s1 ⇓1 tls1 ∧ tllist_all2 tlsim (rel_option bisim) tls1 tls2"
using delay_bisimulation_diverge.simulation_τRuns1[OF delay_bisimulation_diverge_flip]
unfolding flip_simps .
end
locale delay_bisimulation_final_base =
delay_bisimulation_base _ _ _ _ τmove1 τmove2 +
bisimulation_final_base _ _ _ _ final1 final2
for τmove1 :: "('s1, 'tl1) trsys"
and τmove2 :: "('s2, 'tl2) trsys"
and final1 :: "'s1 ⇒ bool"
and final2 :: "'s2 ⇒ bool" +
assumes final1_simulation: "⟦ s1 ≈ s2; final1 s1 ⟧ ⟹ ∃s2'. s2 -τ2→* s2' ∧ s1 ≈ s2' ∧ final2 s2'"
and final2_simulation: "⟦ s1 ≈ s2; final2 s2 ⟧ ⟹ ∃s1'. s1 -τ1→* s1' ∧ s1' ≈ s2 ∧ final1 s1'"
begin
lemma delay_bisimulation_final_base_flip:
"delay_bisimulation_final_base trsys2 trsys1 (flip bisim) τmove2 τmove1 final2 final1"
apply(unfold_locales)
apply(unfold flip_simps)
by(blast intro: final1_simulation final2_simulation)+
end
lemma delay_bisimulation_final_base_flip_simps [flip_simps]:
"delay_bisimulation_final_base trsys2 trsys1 (flip bisim) τmove2 τmove1 final2 final1 =
delay_bisimulation_final_base trsys1 trsys2 bisim τmove1 τmove2 final1 final2"
by(auto dest: delay_bisimulation_final_base.delay_bisimulation_final_base_flip simp only: flip_flip)
context delay_bisimulation_final_base begin
lemma τRuns_terminate_final1:
assumes "s1 ⇓1 tls1"
and "s2 ⇓2 tls2"
and "tllist_all2 tlsim (rel_option bisim) tls1 tls2"
and "tfinite tls1"
and "terminal tls1 = Some s1'"
and "final1 s1'"
shows "∃s2'. tfinite tls2 ∧ terminal tls2 = Some s2' ∧ final2 s2'"
using assms(4) assms(1-3,5-)
apply(induct arbitrary: tls2 s1 s2 rule: tfinite_induct)
apply(auto 4 4 simp add: tllist_all2_TCons1 tllist_all2_TNil1 rel_option_Some1 trsys1.τRuns_simps trsys2.τRuns_simps dest: final1_simulation elim: converse_rtranclpE)
done
lemma τRuns_terminate_final2:
"⟦ s1 ⇓1 tls1; s2 ⇓2 tls2; tllist_all2 tlsim (rel_option bisim) tls1 tls2;
tfinite tls2; terminal tls2 = Some s2'; final2 s2' ⟧
⟹ ∃s1'. tfinite tls1 ∧ terminal tls1 = Some s1' ∧ final1 s1'"
using delay_bisimulation_final_base.τRuns_terminate_final1[where tlsim = "flip tlsim", OF delay_bisimulation_final_base_flip]
unfolding flip_simps by -
end
locale delay_bisimulation_diverge_final =
delay_bisimulation_diverge +
delay_bisimulation_final_base +
constrains trsys1 :: "('s1, 'tl1) trsys"
and trsys2 :: "('s2, 'tl2) trsys"
and bisim :: "('s1, 's2) bisim"
and tlsim :: "('tl1, 'tl2) bisim"
and τmove1 :: "('s1, 'tl1) trsys"
and τmove2 :: "('s2, 'tl2) trsys"
and final1 :: "'s1 ⇒ bool"
and final2 :: "'s2 ⇒ bool"
begin
lemma delay_bisimulation_diverge_final_flip:
"delay_bisimulation_diverge_final trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 final2 final1"
apply(rule delay_bisimulation_diverge_final.intro)
apply(rule delay_bisimulation_diverge_flip)
apply(unfold_locales, unfold flip_simps)
apply(blast intro: final1_simulation final2_simulation)+
done
end
lemma delay_bisimulation_diverge_final_flip_simps [flip_simps]:
"delay_bisimulation_diverge_final trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 final2 final1 =
delay_bisimulation_diverge_final trsys1 trsys2 bisim tlsim τmove1 τmove2 final1 final2"
by(auto dest: delay_bisimulation_diverge_final.delay_bisimulation_diverge_final_flip simp only: flip_flip)
context delay_bisimulation_diverge_final begin
lemma delay_bisimulation_diverge:
"delay_bisimulation_diverge trsys1 trsys2 bisim tlsim τmove1 τmove2"
by(unfold_locales)
lemma delay_bisimulation_final_base:
"delay_bisimulation_final_base trsys1 trsys2 bisim τmove1 τmove2 final1 final2"
by(unfold_locales)
lemma final_simulation1:
"⟦ s1 ≈ s2; s1 -τ1-tls1→* s1'; final1 s1' ⟧
⟹ ∃s2' tls2. s2 -τ2-tls2→* s2' ∧ s1' ≈ s2' ∧ final2 s2' ∧ tls1 [∼] tls2"
by(blast dest: simulation1_τrtrancl3p final1_simulation intro: τrtrancl3p_trans[OF _ silent_moves_into_τrtrancl3p, simplified])
lemma final_simulation2:
"⟦ s1 ≈ s2; s2 -τ2-tls2→* s2'; final2 s2' ⟧
⟹ ∃s1' tls1. s1 -τ1-tls1→* s1' ∧ s1' ≈ s2' ∧ final1 s1' ∧ tls1 [∼] tls2"
by(rule delay_bisimulation_diverge_final.final_simulation1[OF delay_bisimulation_diverge_final_flip, unfolded flip_simps])
end
locale delay_bisimulation_measure_base =
delay_bisimulation_base +
constrains trsys1 :: "'s1 ⇒ 'tl1 ⇒ 's1 ⇒ bool"
and trsys2 :: "'s2 ⇒ 'tl2 ⇒ 's2 ⇒ bool"
and bisim :: "'s1 ⇒ 's2 ⇒ bool"
and tlsim :: "'tl1 ⇒ 'tl2 ⇒ bool"
and τmove1 :: "'s1 ⇒ 'tl1 ⇒ 's1 ⇒ bool"
and τmove2 :: "'s2 ⇒ 'tl2 ⇒ 's2 ⇒ bool"
fixes μ1 :: "'s1 ⇒ 's1 ⇒ bool"
and μ2 :: "'s2 ⇒ 's2 ⇒ bool"
locale delay_bisimulation_measure =
delay_bisimulation_measure_base _ _ _ _ τmove1 τmove2 μ1 μ2 +
delay_bisimulation_obs trsys1 trsys2 bisim tlsim τmove1 τmove2
for τmove1 :: "'s1 ⇒ 'tl1 ⇒ 's1 ⇒ bool"
and τmove2 :: "'s2 ⇒ 'tl2 ⇒ 's2 ⇒ bool"
and μ1 :: "'s1 ⇒ 's1 ⇒ bool"
and μ2 :: "'s2 ⇒ 's2 ⇒ bool" +
assumes simulation_silent1:
"⟦ s1 ≈ s2; s1 -τ1→ s1' ⟧ ⟹ s1' ≈ s2 ∧ μ1^++ s1' s1 ∨ (∃s2'. s2 -τ2→+ s2' ∧ s1' ≈ s2')"
and simulation_silent2:
"⟦ s1 ≈ s2; s2 -τ2→ s2' ⟧ ⟹ s1 ≈ s2' ∧ μ2^++ s2' s2 ∨ (∃s1'. s1 -τ1→+ s1' ∧ s1' ≈ s2')"
and wf_μ1: "wfP μ1"
and wf_μ2: "wfP μ2"
begin
lemma delay_bisimulation_measure_flip:
"delay_bisimulation_measure trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 μ2 μ1"
apply(rule delay_bisimulation_measure.intro)
apply(rule delay_bisimulation_obs_flip)
apply(unfold_locales)
apply(unfold flip_simps)
apply(rule simulation_silent1 simulation_silent2 wf_μ1 wf_μ2|assumption)+
done
end
lemma delay_bisimulation_measure_flip_simps [flip_simps]:
"delay_bisimulation_measure trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 μ2 μ1 =
delay_bisimulation_measure trsys1 trsys2 bisim tlsim τmove1 τmove2 μ1 μ2"
by(auto dest: delay_bisimulation_measure.delay_bisimulation_measure_flip simp only: flip_simps)
context delay_bisimulation_measure begin
lemma simulation_silentst1:
assumes bisim: "s1 ≈ s2" and moves: "s1 -τ1→+ s1'"
shows "s1' ≈ s2 ∧ μ1^++ s1' s1 ∨ (∃s2'. s2 -τ2→+ s2' ∧ s1' ≈ s2')"
using moves bisim
proof induct
case (base s1') thus ?case by(auto dest: simulation_silent1)
next
case (step s1' s1'')
hence "s1' ≈ s2 ∧ μ1⇧+⇧+ s1' s1 ∨ (∃s2'. s2 -τ2→+ s2' ∧ s1' ≈ s2')" by blast
thus ?case
proof
assume "s1' ≈ s2 ∧ μ1⇧+⇧+ s1' s1"
hence "s1' ≈ s2" "μ1⇧+⇧+ s1' s1" by simp_all
with simulation_silent1[OF ‹s1' ≈ s2› ‹s1' -τ1→ s1''›]
show ?thesis by(auto)
next
assume "∃s2'. trsys2.silent_move⇧+⇧+ s2 s2' ∧ s1' ≈ s2'"
then obtain s2' where "s2 -τ2→+ s2'" "s1' ≈ s2'" by blast
with simulation_silent1[OF ‹s1' ≈ s2'› ‹s1' -τ1→ s1''›]
show ?thesis by(auto intro: tranclp_trans)
qed
qed
lemma simulation_silentst2:
"⟦ s1 ≈ s2; s2 -τ2→+ s2' ⟧ ⟹ s1 ≈ s2' ∧ μ2^++ s2' s2 ∨ (∃s1'. s1 -τ1→+ s1' ∧ s1' ≈ s2')"
using delay_bisimulation_measure.simulation_silentst1[OF delay_bisimulation_measure_flip]
unfolding flip_simps .
lemma τdiverge_simulation1:
assumes diverge1: "s1 -τ1→ ∞"
and bisim: "s1 ≈ s2"
shows "s2 -τ2→ ∞"
proof -
from assms have "s1 -τ1→ ∞ ∧ s1 ≈ s2" by blast
thus ?thesis using wfP_trancl[OF wf_μ1]
proof(coinduct rule: trsys2.τdiverge_trancl_measure_coinduct)
case (τdiverge s2 s1)
hence "s1 -τ1→ ∞" "s1 ≈ s2" by simp_all
then obtain s1' where "trsys1.silent_move s1 s1'" "s1' -τ1→ ∞"
by(fastforce elim: trsys1.τdiverge.cases)
from simulation_silent1[OF ‹s1 ≈ s2› ‹trsys1.silent_move s1 s1'›] ‹s1' -τ1→ ∞›
show ?case by auto
qed
qed
lemma τdiverge_simulation2:
"⟦ s2 -τ2→ ∞; s1 ≈ s2 ⟧ ⟹ s1 -τ1→ ∞"
using delay_bisimulation_measure.τdiverge_simulation1[OF delay_bisimulation_measure_flip]
unfolding flip_simps .
lemma τdiverge_bisim_inv:
"s1 ≈ s2 ⟹ s1 -τ1→ ∞ ⟷ s2 -τ2→ ∞"
by(blast intro: τdiverge_simulation1 τdiverge_simulation2)
end
sublocale delay_bisimulation_measure < delay_bisimulation_diverge
proof
fix s1 s2 s1'
assume "s1 ≈ s2" "s1 -τ1→ s1'"
from simulation_silent1[OF this]
show "∃s2'. s2 -τ2→* s2' ∧ s1' ≈ s2'" by(auto intro: tranclp_into_rtranclp)
next
fix s1 s2 s2'
assume "s1 ≈ s2" "s2 -τ2→ s2'"
from simulation_silent2[OF this]
show "∃s1'. s1 -τ1→* s1' ∧ s1' ≈ s2'" by(auto intro: tranclp_into_rtranclp)
next
fix s1 s2
assume "s1 ≈ s2"
thus "s1 -τ1→ ∞ ⟷ s2 -τ2→ ∞" by(rule τdiverge_bisim_inv)
qed
text ‹
Counter example for
@{prop "delay_bisimulation_diverge trsys1 trsys2 bisim tlsim τmove1 τmove2 ⟹ ∃μ1 μ2. delay_bisimulation_measure trsys1 trsys2 bisim tlsim τmove1 τmove2 μ1 μ2"}
(only ‹τ›moves):
\begin{verbatim}
--|
| v
--a ~ x
| |
| |
v v
--b ~ y--
| ^ ^ |
--| |--
\end{verbatim}
›
locale delay_bisimulation_measure_final =
delay_bisimulation_measure +
delay_bisimulation_final_base +
constrains trsys1 :: "('s1, 'tl1) trsys"
and trsys2 :: "('s2, 'tl2) trsys"
and bisim :: "('s1, 's2) bisim"
and tlsim :: "('tl1, 'tl2) bisim"
and τmove1 :: "('s1, 'tl1) trsys"
and τmove2 :: "('s2, 'tl2) trsys"
and μ1 :: "'s1 ⇒ 's1 ⇒ bool"
and μ2 :: "'s2 ⇒ 's2 ⇒ bool"
and final1 :: "'s1 ⇒ bool"
and final2 :: "'s2 ⇒ bool"
sublocale delay_bisimulation_measure_final < delay_bisimulation_diverge_final
by unfold_locales
locale τinv = delay_bisimulation_base +
constrains trsys1 :: "('s1, 'tl1) trsys"
and trsys2 :: "('s2, 'tl2) trsys"
and bisim :: "('s1, 's2) bisim"
and tlsim :: "('tl1, 'tl2) bisim"
and τmove1 :: "('s1, 'tl1) trsys"
and τmove2 :: "('s2, 'tl2) trsys"
and τmoves1 :: "'s1 ⇒ 's1 ⇒ bool"
and τmoves2 :: "'s2 ⇒ 's2 ⇒ bool"
assumes τinv: "⟦ s1 ≈ s2; s1 -1-tl1→ s1'; s2 -2-tl2→ s2'; s1' ≈ s2'; tl1 ∼ tl2 ⟧
⟹ τmove1 s1 tl1 s1' ⟷ τmove2 s2 tl2 s2'"
begin
lemma τinv_flip:
"τinv trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1"
by(unfold_locales)(unfold flip_simps,rule τinv[symmetric])
end
lemma τinv_flip_simps [flip_simps]:
"τinv trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 = τinv trsys1 trsys2 bisim tlsim τmove1 τmove2"
by(auto dest: τinv.τinv_flip simp only: flip_simps)
locale bisimulation_into_delay =
bisimulation + τinv +
constrains trsys1 :: "('s1, 'tl1) trsys"
and trsys2 :: "('s2, 'tl2) trsys"
and bisim :: "('s1, 's2) bisim"
and tlsim :: "('tl1, 'tl2) bisim"
and τmove1 :: "('s1, 'tl1) trsys"
and τmove2 :: "('s2, 'tl2) trsys"
begin
lemma bisimulation_into_delay_flip:
"bisimulation_into_delay trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1"
by(intro_locales)(intro bisimulation_flip τinv_flip)+
end
lemma bisimulation_into_delay_flip_simps [flip_simps]:
"bisimulation_into_delay trsys2 trsys1 (flip bisim) (flip tlsim) τmove2 τmove1 =
bisimulation_into_delay trsys1 trsys2 bisim tlsim τmove1 τmove2"
by(auto dest: bisimulation_into_delay.bisimulation_into_delay_flip simp only: flip_simps)
context bisimulation_into_delay begin
lemma simulation_silent1_aux:
assumes bisim: "s1 ≈ s2" and "s1 -τ1→ s1'"
shows "s1' ≈ s2 ∧ μ1⇧+⇧+ s1' s1 ∨ (∃s2'. s2 -τ2→+ s2' ∧ s1' ≈ s2')"
proof -
from assms obtain tl1 where tr1: "s1 -1-tl1→ s1'"
and τ1: "τmove1 s1 tl1 s1'" by(auto)
from simulation1[OF bisim tr1]
obtain s2' tl2 where tr2: "s2 -2-tl2→ s2'"
and bisim': "s1' ≈ s2'" and tlsim: "tl1 ∼ tl2" by blast
from τinv[OF bisim tr1 tr2 bisim' tlsim] τ1 have τ2: "τmove2 s2 tl2 s2'" by simp
from tr2 τ2 have "s2 -τ2→+ s2'" by(auto)
with bisim' show ?thesis by blast
qed
lemma simulation_silent2_aux:
"⟦ s1 ≈ s2; s2 -τ2→ s2' ⟧ ⟹ s1 ≈ s2' ∧ μ2⇧+⇧+ s2' s2 ∨ (∃s1'. s1 -τ1→+ s1' ∧ s1' ≈ s2')"
using bisimulation_into_delay.simulation_silent1_aux[OF bisimulation_into_delay_flip]
unfolding flip_simps .
lemma simulation1_aux:
assumes bisim: "s1 ≈ s2" and tr1: "s1 -1-tl1→ s1'" and τ1: "¬ τmove1 s1 tl1 s1'"
shows "∃s2' s2'' tl2. s2 -τ2→* s2' ∧ s2' -2-tl2→ s2'' ∧ ¬ τmove2 s2' tl2 s2'' ∧ s1' ≈ s2'' ∧ tl1 ∼ tl2"
proof -
from simulation1[OF bisim tr1]
obtain s2' tl2 where tr2: "s2 -2-tl2→ s2'"
and bisim': "s1' ≈ s2'" and tlsim: "tl1 ∼ tl2" by blast
from τinv[OF bisim tr1 tr2 bisim' tlsim] τ1 have τ2: "¬ τmove2 s2 tl2 s2'" by simp
with bisim' tr2 tlsim show ?thesis by blast
qed
lemma simulation2_aux:
"⟦ s1 ≈ s2; s2 -2-tl2→ s2'; ¬ τmove2 s2 tl2 s2' ⟧
⟹ ∃s1' s1'' tl1. s1 -τ1→* s1' ∧ s1' -1-tl1→ s1'' ∧ ¬ τmove1 s1' tl1 s1'' ∧ s1'' ≈ s2' ∧ tl1 ∼ tl2"
using bisimulation_into_delay.simulation1_aux[OF bisimulation_into_delay_flip]
unfolding flip_simps .
lemma delay_bisimulation_measure:
assumes wf_μ1: "wfP μ1"
and wf_μ2: "wfP μ2"
shows "delay_bisimulation_measure trsys1 trsys2 bisim tlsim τmove1 τmove2 μ1 μ2"
apply(unfold_locales)
apply(rule simulation_silent1_aux simulation_silent2_aux simulation1_aux simulation2_aux wf_μ1 wf_μ2|assumption)+
done
lemma delay_bisimulation:
"delay_bisimulation_diverge trsys1 trsys2 bisim tlsim τmove1 τmove2"
proof -
interpret delay_bisimulation_measure trsys1 trsys2 bisim tlsim τmove1 τmove2 "λs s'. False" "λs s'. False"
by(blast intro: delay_bisimulation_measure wfP_empty)
show ?thesis ..
qed
end
sublocale bisimulation_into_delay < delay_bisimulation_diverge
by(rule delay_bisimulation)
lemma delay_bisimulation_conv_bisimulation:
"delay_bisimulation_diverge trsys1 trsys2 bisim tlsim (λs tl s'. False) (λs tl s'. False) =
bisimulation trsys1 trsys2 bisim tlsim"
(is "?lhs = ?rhs")
proof
assume ?lhs
then interpret delay_bisimulation_diverge trsys1 trsys2 bisim tlsim "λs tl s'. False" "λs tl s'. False" .
show ?rhs by(unfold_locales)(fastforce simp add: τmoves_False dest: simulation1 simulation2)+
next
assume ?rhs
then interpret bisimulation trsys1 trsys2 bisim tlsim .
interpret bisimulation_into_delay trsys1 trsys2 bisim tlsim "λs tl s'. False" "λs tl s'. False"
by(unfold_locales)(rule refl)
show ?lhs by unfold_locales
qed
context bisimulation_final begin
lemma delay_bisimulation_final_base:
"delay_bisimulation_final_base trsys1 trsys2 bisim τmove1 τmove2 final1 final2"
by(unfold_locales)(auto simp add: bisim_final)
end
sublocale bisimulation_final < delay_bisimulation_final_base
by(rule delay_bisimulation_final_base)
subsection ‹Transitivity for bisimulations›
definition bisim_compose :: "('s1, 's2) bisim ⇒ ('s2, 's3) bisim ⇒ ('s1, 's3) bisim" (infixr "∘⇩B" 60)
where "(bisim1 ∘⇩B bisim2) s1 s3 ≡ ∃s2. bisim1 s1 s2 ∧ bisim2 s2 s3"
lemma bisim_composeI [intro]:
"⟦ bisim12 s1 s2; bisim23 s2 s3 ⟧ ⟹ (bisim12 ∘⇩B bisim23) s1 s3"
by(auto simp add: bisim_compose_def)
lemma bisim_composeE [elim!]:
assumes bisim: "(bisim12 ∘⇩B bisim23) s1 s3"
obtains s2 where "bisim12 s1 s2" "bisim23 s2 s3"
by(atomize_elim)(rule bisim[unfolded bisim_compose_def])
lemma bisim_compose_assoc [simp]:
"(bisim12 ∘⇩B bisim23) ∘⇩B bisim34 = bisim12 ∘⇩B bisim23 ∘⇩B bisim34"
by(auto simp add: fun_eq_iff)
lemma bisim_compose_conv_relcomp:
"case_prod (bisim_compose bisim12 bisim23) = (λx. x ∈ relcomp (Collect (case_prod bisim12)) (Collect (case_prod bisim23)))"
by(auto simp add: relcomp_unfold)
lemma list_all2_bisim_composeI:
"⟦ list_all2 A xs ys; list_all2 B ys zs ⟧
⟹ list_all2 (A ∘⇩B B) xs zs"
by(rule list_all2_trans) auto+
lemma delay_bisimulation_diverge_compose:
assumes wbisim12: "delay_bisimulation_diverge trsys1 trsys2 bisim12 tlsim12 τmove1 τmove2"
and wbisim23: "delay_bisimulation_diverge trsys2 trsys3 bisim23 tlsim23 τmove2 τmove3"
shows "delay_bisimulation_diverge trsys1 trsys3 (bisim12 ∘⇩B bisim23) (tlsim12 ∘⇩B tlsim23) τmove1 τmove3"
proof -
interpret trsys1: τtrsys trsys1 τmove1 .
interpret trsys2: τtrsys trsys2 τmove2 .
interpret trsys3: τtrsys trsys3 τmove3 .
interpret wb12: delay_bisimulation_diverge trsys1 trsys2 bisim12 tlsim12 τmove1 τmove2 by(auto intro: wbisim12)
interpret wb23: delay_bisimulation_diverge trsys2 trsys3 bisim23 tlsim23 τmove2 τmove3 by(auto intro: wbisim23)
show ?thesis
proof
fix s1 s3 s1'
assume bisim: "(bisim12 ∘⇩B bisim23) s1 s3" and tr1: "trsys1.silent_move s1 s1'"
from bisim obtain s2 where bisim1: "bisim12 s1 s2" and bisim2: "bisim23 s2 s3" by blast
from wb12.simulation_silent1[OF bisim1 tr1] obtain s2'
where tr2: "trsys2.silent_moves s2 s2'" and bisim1': "bisim12 s1' s2'" by blast
from wb23.simulation_silents1[OF bisim2 tr2] obtain s3'
where "trsys3.silent_moves s3 s3'" "bisim23 s2' s3'" by blast
with bisim1' show "∃s3'. trsys3.silent_moves s3 s3' ∧ (bisim12 ∘⇩B bisim23) s1' s3'"
by(blast intro: bisim_composeI)
next
fix s1 s3 s3'
assume bisim: "(bisim12 ∘⇩B bisim23) s1 s3" and tr3: "trsys3.silent_move s3 s3'"
from bisim obtain s2 where bisim1: "bisim12 s1 s2" and bisim2: "bisim23 s2 s3" by blast
from wb23.simulation_silent2[OF bisim2 tr3] obtain s2'
where tr2: "trsys2.silent_moves s2 s2'" and bisim2': "bisim23 s2' s3'" by blast
from wb12.simulation_silents2[OF bisim1 tr2] obtain s1'
where "trsys1.silent_moves s1 s1'" "bisim12 s1' s2'" by blast
with bisim2' show "∃s1'. trsys1.silent_moves s1 s1' ∧ (bisim12 ∘⇩B bisim23) s1' s3'"
by(blast intro: bisim_composeI)
next
fix s1 s3 tl1 s1'
assume bisim: "(bisim12 ∘⇩B bisim23) s1 s3"
and tr1: "trsys1 s1 tl1 s1'" and τ1: "¬ τmove1 s1 tl1 s1'"
from bisim obtain s2 where bisim1: "bisim12 s1 s2" and bisim2: "bisim23 s2 s3" by blast
from wb12.simulation1[OF bisim1 tr1 τ1] obtain s2' s2'' tl2
where tr21: "trsys2.silent_moves s2 s2'" and tr22: "trsys2 s2' tl2 s2''" and τ2: "¬ τmove2 s2' tl2 s2''"
and bisim1': "bisim12 s1' s2''" and tlsim1: "tlsim12 tl1 tl2" by blast
from wb23.simulation_silents1[OF bisim2 tr21] obtain s3'
where tr31: "trsys3.silent_moves s3 s3'" and bisim2': "bisim23 s2' s3'" by blast
from wb23.simulation1[OF bisim2' tr22 τ2] obtain s3'' s3''' tl3
where "trsys3.silent_moves s3' s3''" "trsys3 s3'' tl3 s3'''"
"¬ τmove3 s3'' tl3 s3'''" "bisim23 s2'' s3'''" "tlsim23 tl2 tl3" by blast
with tr31 bisim1' tlsim1
show "∃s3' s3'' tl3. trsys3.silent_moves s3 s3' ∧ trsys3 s3' tl3 s3'' ∧ ¬ τmove3 s3' tl3 s3'' ∧
(bisim12 ∘⇩B bisim23) s1' s3'' ∧ (tlsim12 ∘⇩B tlsim23) tl1 tl3"
by(blast intro: rtranclp_trans bisim_composeI)
next
fix s1 s3 tl3 s3'
assume bisim: "(bisim12 ∘⇩B bisim23) s1 s3"
and tr3: "trsys3 s3 tl3 s3'" and τ3: "¬ τmove3 s3 tl3 s3'"
from bisim obtain s2 where bisim1: "bisim12 s1 s2" and bisim2: "bisim23 s2 s3" by blast
from wb23.simulation2[OF bisim2 tr3 τ3] obtain s2' s2'' tl2
where tr21: "trsys2.silent_moves s2 s2'" and tr22: "trsys2 s2' tl2 s2''" and τ2: "¬ τmove2 s2' tl2 s2''"
and bisim2': "bisim23 s2'' s3'" and tlsim2: "tlsim23 tl2 tl3" by blast
from wb12.simulation_silents2[OF bisim1 tr21] obtain s1'
where tr11: "trsys1.silent_moves s1 s1'" and bisim1': "bisim12 s1' s2'" by blast
from wb12.simulation2[OF bisim1' tr22 τ2] obtain s1'' s1''' tl1
where "trsys1.silent_moves s1' s1''" "trsys1 s1'' tl1 s1'''"
"¬ τmove1 s1'' tl1 s1'''" "bisim12 s1''' s2''" "tlsim12 tl1 tl2" by blast
with tr11 bisim2' tlsim2
show "∃s1' s1'' tl1. trsys1.silent_moves s1 s1' ∧ trsys1 s1' tl1 s1'' ∧ ¬ τmove1 s1' tl1 s1'' ∧
(bisim12 ∘⇩B bisim23) s1'' s3' ∧ (tlsim12 ∘⇩B tlsim23) tl1 tl3"
by(blast intro: rtranclp_trans bisim_composeI)
next
fix s1 s2
assume "(bisim12 ∘⇩B bisim23) s1 s2"
thus "τtrsys.τdiverge trsys1 τmove1 s1 = τtrsys.τdiverge trsys3 τmove3 s2"
by(auto simp add: wb12.τdiverge_bisim_inv wb23.τdiverge_bisim_inv)
qed
qed
lemma bisimulation_bisim_compose:
"⟦ bisimulation trsys1 trsys2 bisim12 tlsim12; bisimulation trsys2 trsys3 bisim23 tlsim23 ⟧
⟹ bisimulation trsys1 trsys3 (bisim_compose bisim12 bisim23) (bisim_compose tlsim12 tlsim23)"
unfolding delay_bisimulation_conv_bisimulation[symmetric]
by(rule delay_bisimulation_diverge_compose)
lemma delay_bisimulation_diverge_final_compose:
fixes τmove1 τmove2
assumes wbisim12: "delay_bisimulation_diverge_final trsys1 trsys2 bisim12 tlsim12 τmove1 τmove2 final1 final2"
and wbisim23: "delay_bisimulation_diverge_final trsys2 trsys3 bisim23 tlsim23 τmove2 τmove3 final2 final3"
shows "delay_bisimulation_diverge_final trsys1 trsys3 (bisim12 ∘⇩B bisim23) (tlsim12 ∘⇩B tlsim23) τmove1 τmove3 final1 final3"
proof -
interpret trsys1: τtrsys trsys1 τmove1 .
interpret trsys2: τtrsys trsys2 τmove2 .
interpret trsys3: τtrsys trsys3 τmove3 .
interpret wb12: delay_bisimulation_diverge_final trsys1 trsys2 bisim12 tlsim12 τmove1 τmove2 final1 final2
by(auto intro: wbisim12)
interpret wb23: delay_bisimulation_diverge_final trsys2 trsys3 bisim23 tlsim23 τmove2 τmove3 final2 final3
by(auto intro: wbisim23)
interpret delay_bisimulation_diverge trsys1 trsys3 "bisim12 ∘⇩B bisim23" "tlsim12 ∘⇩B tlsim23" τmove1 τmove3
by(rule delay_bisimulation_diverge_compose)(unfold_locales)
show ?thesis
proof
fix s1 s3
assume "(bisim12 ∘⇩B bisim23) s1 s3" "final1 s1"
from ‹(bisim12 ∘⇩B bisim23) s1 s3› obtain s2 where "bisim12 s1 s2" and "bisim23 s2 s3" ..
from wb12.final1_simulation[OF ‹bisim12 s1 s2› ‹final1 s1›]
obtain s2' where "trsys2.silent_moves s2 s2'" "bisim12 s1 s2'" "final2 s2'" by blast
from wb23.simulation_silents1[OF ‹bisim23 s2 s3› ‹trsys2.silent_moves s2 s2'›]
obtain s3' where "trsys3.silent_moves s3 s3'" "bisim23 s2' s3'" by blast
from wb23.final1_simulation[OF ‹bisim23 s2' s3'› ‹final2 s2'›]
obtain s3'' where "trsys3.silent_moves s3' s3''" "bisim23 s2' s3''" "final3 s3''" by blast
from ‹trsys3.silent_moves s3 s3'› ‹trsys3.silent_moves s3' s3''›
have "trsys3.silent_moves s3 s3''" by(rule rtranclp_trans)
moreover from ‹bisim12 s1 s2'› ‹bisim23 s2' s3''›
have "(bisim12 ∘⇩B bisim23) s1 s3''" ..
ultimately show "∃s3'. trsys3.silent_moves s3 s3' ∧ (bisim12 ∘⇩B bisim23) s1 s3' ∧ final3 s3'"
using ‹final3 s3''› by iprover
next
fix s1 s3
assume "(bisim12 ∘⇩B bisim23) s1 s3" "final3 s3"
from ‹(bisim12 ∘⇩B bisim23) s1 s3› obtain s2 where "bisim12 s1 s2" and "bisim23 s2 s3" ..
from wb23.final2_simulation[OF ‹bisim23 s2 s3› ‹final3 s3›]
obtain s2' where "trsys2.silent_moves s2 s2'" "bisim23 s2' s3" "final2 s2'" by blast
from wb12.simulation_silents2[OF ‹bisim12 s1 s2› ‹trsys2.silent_moves s2 s2'›]
obtain s1' where "trsys1.silent_moves s1 s1'" "bisim12 s1' s2'" by blast
from wb12.final2_simulation[OF ‹bisim12 s1' s2'› ‹final2 s2'›]
obtain s1'' where "trsys1.silent_moves s1' s1''" "bisim12 s1'' s2'" "final1 s1''" by blast
from ‹trsys1.silent_moves s1 s1'› ‹trsys1.silent_moves s1' s1''›
have "trsys1.silent_moves s1 s1''" by(rule rtranclp_trans)
moreover from ‹bisim12 s1'' s2'› ‹bisim23 s2' s3›
have "(bisim12 ∘⇩B bisim23) s1'' s3" ..
ultimately show "∃s1'. trsys1.silent_moves s1 s1' ∧ (bisim12 ∘⇩B bisim23) s1' s3 ∧ final1 s1'"
using ‹final1 s1''› by iprover
qed
qed
end
Theory FWBisimulation
section ‹Bisimulation relations for the multithreaded semantics›
theory FWBisimulation
imports
FWLTS
Bisimulation
begin
subsection ‹Definitions for lifting bisimulation relations›
primrec nta_bisim :: "('t ⇒ ('x1 × 'm1, 'x2 × 'm2) bisim) ⇒ (('t,'x1,'m1) new_thread_action, ('t,'x2,'m2) new_thread_action) bisim"
where
[code del]: "nta_bisim bisim (NewThread t x m) ta = (∃x' m'. ta = NewThread t x' m' ∧ bisim t (x, m) (x', m'))"
| "nta_bisim bisim (ThreadExists t b) ta = (ta = ThreadExists t b)"
lemma nta_bisim_1_code [code]:
"nta_bisim bisim (NewThread t x m) ta = (case ta of NewThread t' x' m' ⇒ t = t' ∧ bisim t (x, m) (x', m') | _ ⇒ False)"
by(auto split: new_thread_action.split)
lemma nta_bisim_simps_sym [simp]:
"nta_bisim bisim ta (NewThread t x m) = (∃x' m'. ta = NewThread t x' m' ∧ bisim t (x', m') (x, m))"
"nta_bisim bisim ta (ThreadExists t b) = (ta = ThreadExists t b)"
by(cases ta, auto)+
definition ta_bisim :: "('t ⇒ ('x1 × 'm1, 'x2 × 'm2) bisim) ⇒ (('l,'t,'x1,'m1,'w,'o) thread_action, ('l,'t,'x2,'m2,'w,'o) thread_action) bisim"
where
"ta_bisim bisim ta1 ta2 ≡
⦃ ta1 ⦄⇘l⇙ = ⦃ ta2 ⦄⇘l⇙ ∧ ⦃ ta1 ⦄⇘w⇙ = ⦃ ta2 ⦄⇘w⇙ ∧ ⦃ ta1 ⦄⇘c⇙ = ⦃ ta2 ⦄⇘c⇙ ∧ ⦃ ta1 ⦄⇘o⇙ = ⦃ ta2 ⦄⇘o⇙ ∧ ⦃ ta1 ⦄⇘i⇙ = ⦃ ta2 ⦄⇘i⇙ ∧
list_all2 (nta_bisim bisim) ⦃ ta1 ⦄⇘t⇙ ⦃ ta2 ⦄⇘t⇙"
lemma ta_bisim_empty [iff]: "ta_bisim bisim ε ε"
by(auto simp add: ta_bisim_def)
lemma ta_bisim_ε [simp]:
"ta_bisim b ε ta' ⟷ ta' = ε" "ta_bisim b ta ε ⟷ ta = ε"
apply(cases ta', fastforce simp add: ta_bisim_def)
apply(cases ta, fastforce simp add: ta_bisim_def)
done
lemma nta_bisim_mono:
assumes major: "nta_bisim bisim ta ta'"
and mono: "⋀t s1 s2. bisim t s1 s2 ⟹ bisim' t s1 s2"
shows "nta_bisim bisim' ta ta'"
using major by(cases ta)(auto intro: mono)
lemma ta_bisim_mono:
assumes major: "ta_bisim bisim ta1 ta2"
and mono: "⋀t s1 s2. bisim t s1 s2 ⟹ bisim' t s1 s2"
shows "ta_bisim bisim' ta1 ta2"
using major
by(auto simp add: ta_bisim_def elim!: List.list_all2_mono nta_bisim_mono intro: mono)
lemma nta_bisim_flip [flip_simps]:
"nta_bisim (λt. flip (bisim t)) = flip (nta_bisim bisim)"
by(rule ext)(case_tac x, auto simp add: flip_simps)
lemma ta_bisim_flip [flip_simps]:
"ta_bisim (λt. flip (bisim t)) = flip (ta_bisim bisim)"
by(auto simp add: fun_eq_iff flip_simps ta_bisim_def)
locale FWbisimulation_base =
r1: multithreaded_base final1 r1 convert_RA +
r2: multithreaded_base final2 r2 convert_RA
for final1 :: "'x1 ⇒ bool"
and r1 :: "('l,'t,'x1,'m1,'w,'o) semantics" ("_ ⊢ _ -1-_→ _" [50, 0, 0, 50] 80)
and final2 :: "'x2 ⇒ bool"
and r2 :: "('l,'t,'x2,'m2,'w,'o) semantics" ("_ ⊢ _ -2-_→ _" [50, 0, 0, 50] 80)
and convert_RA :: "'l released_locks ⇒ 'o list"
+
fixes bisim :: "'t ⇒ ('x1 × 'm1, 'x2 × 'm2) bisim" ("_ ⊢ _/ ≈ _" [50, 50, 50] 60)
and bisim_wait :: "('x1, 'x2) bisim" ("_/ ≈w _" [50, 50] 60)
begin
notation r1.redT_syntax1 ("_ -1-_▹_→ _" [50,0,0,50] 80)
notation r2.redT_syntax1 ("_ -2-_▹_→ _" [50,0,0,50] 80)
notation r1.RedT ("_ -1-▹_→* _" [50,0,50] 80)
notation r2.RedT ("_ -2-▹_→* _" [50,0,50] 80)
notation r1.must_sync ("_ ⊢ ⟨_,/ _⟩/ ≀1" [50,0,0] 81)
notation r2.must_sync ("_ ⊢ ⟨_,/ _⟩/ ≀2" [50,0,0] 81)
notation r1.can_sync ("_ ⊢ ⟨_,/ _⟩/ _/ ≀1" [50,0,0,0] 81)
notation r2.can_sync ("_ ⊢ ⟨_,/ _⟩/ _/ ≀2" [50,0,0,0] 81)
abbreviation ta_bisim_bisim_syntax ("_/ ∼m _" [50, 50] 60)
where "ta1 ∼m ta2 ≡ ta_bisim bisim ta1 ta2"
definition tbisim :: "bool ⇒ 't ⇒ ('x1 × 'l released_locks) option ⇒ 'm1 ⇒ ('x2 × 'l released_locks) option ⇒ 'm2 ⇒ bool" where
"⋀ln. tbisim nw t ts1 m1 ts2 m2 ⟷
(case ts1 of None ⇒ ts2 = None
| ⌊(x1, ln)⌋ ⇒ (∃x2. ts2 = ⌊(x2, ln)⌋ ∧ t ⊢ (x1, m1) ≈ (x2, m2) ∧ (nw ∨ x1 ≈w x2)))"
lemma tbisim_NoneI: "tbisim w t None m None m'"
by(simp add: tbisim_def)
lemma tbisim_SomeI:
"⋀ln. ⟦ t ⊢ (x, m) ≈ (x', m'); nw ∨ x ≈w x' ⟧ ⟹ tbisim nw t (Some (x, ln)) m (Some (x', ln)) m'"
by(simp add: tbisim_def)
lemma tbisim_cases[consumes 1, case_names None Some]:
assumes major: "tbisim nw t ts1 m1 ts2 m2"
and "⟦ ts1 = None; ts2 = None ⟧ ⟹ thesis"
and "⋀x ln x'. ⟦ ts1 = ⌊(x, ln)⌋; ts2 = ⌊(x', ln)⌋; t ⊢ (x, m1) ≈ (x', m2); nw ∨ x ≈w x' ⟧ ⟹ thesis"
shows thesis
using assms
by(auto simp add: tbisim_def)
definition mbisim :: "(('l,'t,'x1,'m1,'w) state, ('l,'t,'x2,'m2,'w) state) bisim" ("_ ≈m _" [50, 50] 60)
where
"s1 ≈m s2 ≡
finite (dom (thr s1)) ∧ locks s1 = locks s2 ∧ wset s1 = wset s2 ∧ wset_thread_ok (wset s1) (thr s1) ∧
interrupts s1 = interrupts s2 ∧
(∀t. tbisim (wset s2 t = None) t (thr s1 t) (shr s1) (thr s2 t) (shr s2))"
lemma mbisim_thrNone_eq: "s1 ≈m s2 ⟹ thr s1 t = None ⟷ thr s2 t = None"
unfolding mbisim_def tbisim_def
apply(clarify)
apply(erule allE[where x=t])
apply(clarsimp)
done
lemma mbisim_thrD1:
"⋀ln. ⟦ s1 ≈m s2; thr s1 t = ⌊(x, ln)⌋ ⟧
⟹ ∃x'. thr s2 t = ⌊(x', ln)⌋ ∧ t ⊢ (x, shr s1) ≈ (x', shr s2) ∧ (wset s1 t = None ∨ x ≈w x')"
by(fastforce simp add: mbisim_def tbisim_def)
lemma mbisim_thrD2:
"⋀ln. ⟦ s1 ≈m s2; thr s2 t = ⌊(x, ln)⌋ ⟧
⟹ ∃x'. thr s1 t = ⌊(x', ln)⌋ ∧ t ⊢ (x', shr s1) ≈ (x, shr s2) ∧ (wset s2 t = None ∨ x' ≈w x)"
by(frule mbisim_thrNone_eq[where t=t])(cases "thr s1 t",(fastforce simp add: mbisim_def tbisim_def)+)
lemma mbisim_dom_eq: "s1 ≈m s2 ⟹ dom (thr s1) = dom (thr s2)"
apply(clarsimp simp add: dom_def fun_eq_iff simp del: not_None_eq)
apply(rule Collect_cong)
apply(drule mbisim_thrNone_eq)
apply(simp del: not_None_eq)
done
lemma mbisim_wset_thread_ok1:
"s1 ≈m s2 ⟹ wset_thread_ok (wset s1) (thr s1)"
by(clarsimp simp add: mbisim_def)
lemma mbisim_wset_thread_ok2:
assumes "s1 ≈m s2"
shows "wset_thread_ok (wset s2) (thr s2)"
using assms
apply(clarsimp simp add: mbisim_def)
apply(auto intro!: wset_thread_okI simp add: mbisim_thrNone_eq[OF assms, THEN sym] dest: wset_thread_okD)
done
lemma mbisimI:
"⟦ finite (dom (thr s1)); locks s1 = locks s2; wset s1 = wset s2; interrupts s1 = interrupts s2;
wset_thread_ok (wset s1) (thr s1);
⋀t. thr s1 t = None ⟹ thr s2 t = None;
⋀t x1 ln. thr s1 t = ⌊(x1, ln)⌋ ⟹ ∃x2. thr s2 t = ⌊(x2, ln)⌋ ∧ t ⊢ (x1, shr s1) ≈ (x2, shr s2) ∧ (wset s2 t = None ∨ x1 ≈w x2) ⟧
⟹ s1 ≈m s2"
by(fastforce simp add: mbisim_def tbisim_def)
lemma mbisimI2:
"⟦ finite (dom (thr s2)); locks s1 = locks s2; wset s1 = wset s2; interrupts s1 = interrupts s2;
wset_thread_ok (wset s2) (thr s2);
⋀t. thr s2 t = None ⟹ thr s1 t = None;
⋀t x2 ln. thr s2 t = ⌊(x2, ln)⌋ ⟹ ∃x1. thr s1 t = ⌊(x1, ln)⌋ ∧ t ⊢ (x1, shr s1) ≈ (x2, shr s2) ∧ (wset s2 t = None ∨ x1 ≈w x2) ⟧
⟹ s1 ≈m s2"
apply(auto simp add: mbisim_def tbisim_def)
prefer 2
apply(rule wset_thread_okI)
apply(case_tac "thr s2 t")
apply(auto dest!: wset_thread_okD)[1]
apply fastforce
apply(erule back_subst[where P=finite])
apply(clarsimp simp add: dom_def fun_eq_iff simp del: not_None_eq)
defer
apply(rename_tac t)
apply(case_tac [!] "thr s2 t")
by fastforce+
lemma mbisim_finite1:
"s1 ≈m s2 ⟹ finite (dom (thr s1))"
by(simp add: mbisim_def)
lemma mbisim_finite2:
"s1 ≈m s2 ⟹ finite (dom (thr s2))"
by(frule mbisim_finite1)(simp add: mbisim_dom_eq)
definition mta_bisim :: "('t × ('l,'t,'x1,'m1,'w,'o) thread_action,
't × ('l,'t,'x2,'m2,'w,'o) thread_action) bisim"
("_/ ∼T _" [50, 50] 60)
where "tta1 ∼T tta2 ≡ fst tta1 = fst tta2 ∧ snd tta1 ∼m snd tta2"
lemma mta_bisim_conv [simp]: "(t, ta1) ∼T (t', ta2) ⟷ t = t' ∧ ta1 ∼m ta2"
by(simp add: mta_bisim_def)
definition bisim_inv :: "bool" where
"bisim_inv ≡ (∀s1 ta1 s1' s2 t. t ⊢ s1 ≈ s2 ⟶ t ⊢ s1 -1-ta1→ s1' ⟶ (∃s2'. t ⊢ s1' ≈ s2')) ∧
(∀s2 ta2 s2' s1 t. t ⊢ s1 ≈ s2 ⟶ t ⊢ s2 -2-ta2→ s2' ⟶ (∃s1'. t ⊢ s1' ≈ s2'))"
lemma bisim_invI:
"⟦ ⋀s1 ta1 s1' s2 t. ⟦ t ⊢ s1 ≈ s2; t ⊢ s1 -1-ta1→ s1' ⟧ ⟹ ∃s2'. t ⊢ s1' ≈ s2';
⋀s2 ta2 s2' s1 t. ⟦ t ⊢ s1 ≈ s2; t ⊢ s2 -2-ta2→ s2' ⟧ ⟹ ∃s1'. t ⊢ s1' ≈ s2' ⟧
⟹ bisim_inv"
by(auto simp add: bisim_inv_def)
lemma bisim_invD1:
"⟦ bisim_inv; t ⊢ s1 ≈ s2; t ⊢ s1 -1-ta1→ s1' ⟧ ⟹ ∃s2'. t ⊢ s1' ≈ s2'"
unfolding bisim_inv_def by blast
lemma bisim_invD2:
"⟦ bisim_inv; t ⊢ s1 ≈ s2; t ⊢ s2 -2-ta2→ s2' ⟧ ⟹ ∃s1'. t ⊢ s1' ≈ s2'"
unfolding bisim_inv_def by blast
lemma thread_oks_bisim_inv:
"⟦ ∀t. ts1 t = None ⟷ ts2 t = None; list_all2 (nta_bisim bisim) tas1 tas2 ⟧
⟹ thread_oks ts1 tas1 ⟷ thread_oks ts2 tas2"
proof(induct tas2 arbitrary: tas1 ts1 ts2)
case Nil thus ?case by(simp)
next
case (Cons ta2 TAS2 tas1 TS1 TS2)
note IH = ‹⋀ts1 tas1 ts2. ⟦ ∀t. ts1 t = None ⟷ ts2 t = None; list_all2 (nta_bisim bisim) tas1 TAS2 ⟧
⟹ thread_oks ts1 tas1 ⟷ thread_oks ts2 TAS2›
note eqNone = ‹∀t. TS1 t = None ⟷ TS2 t = None›[rule_format]
hence fti: "free_thread_id TS1 = free_thread_id TS2" by(auto simp add: free_thread_id_def)
from ‹list_all2 (nta_bisim bisim) tas1 (ta2 # TAS2)›
obtain ta1 TAS1 where "tas1 = ta1 # TAS1" "nta_bisim bisim ta1 ta2" "list_all2 (nta_bisim bisim) TAS1 TAS2"
by(auto simp add: list_all2_Cons2)
moreover
{ fix t
from ‹nta_bisim bisim ta1 ta2› have "redT_updT' TS1 ta1 t = None ⟷ redT_updT' TS2 ta2 t = None"
by(cases ta1, auto split: if_split_asm simp add: eqNone) }
ultimately have "thread_oks (redT_updT' TS1 ta1) TAS1 ⟷ thread_oks (redT_updT' TS2 ta2) TAS2"
by -(rule IH, auto)
moreover from ‹nta_bisim bisim ta1 ta2› fti have "thread_ok TS1 ta1 = thread_ok TS2 ta2" by(cases ta1, auto)
ultimately show ?case using ‹tas1 = ta1 # TAS1› by auto
qed
lemma redT_updT_nta_bisim_inv:
"⟦ nta_bisim bisim ta1 ta2; ts1 T = None ⟷ ts2 T = None ⟧ ⟹ redT_updT ts1 ta1 T = None ⟷ redT_updT ts2 ta2 T = None"
by(cases ta1, auto)
lemma redT_updTs_nta_bisim_inv:
"⟦ list_all2 (nta_bisim bisim) tas1 tas2; ts1 T = None ⟷ ts2 T = None ⟧
⟹ redT_updTs ts1 tas1 T = None ⟷ redT_updTs ts2 tas2 T = None"
proof(induct tas1 arbitrary: tas2 ts1 ts2)
case Nil thus ?case by(simp)
next
case (Cons TA1 TAS1 tas2 TS1 TS2)
note IH = ‹⋀tas2 ts1 ts2. ⟦list_all2 (nta_bisim bisim) TAS1 tas2; (ts1 T = None) = (ts2 T = None)⟧
⟹ (redT_updTs ts1 TAS1 T = None) = (redT_updTs ts2 tas2 T = None)›
from ‹list_all2 (nta_bisim bisim) (TA1 # TAS1) tas2›
obtain TA2 TAS2 where "tas2 = TA2 # TAS2" "nta_bisim bisim TA1 TA2" "list_all2 (nta_bisim bisim) TAS1 TAS2"
by(auto simp add: list_all2_Cons1)
from ‹nta_bisim bisim TA1 TA2› ‹(TS1 T = None) = (TS2 T = None)›
have "redT_updT TS1 TA1 T = None ⟷ redT_updT TS2 TA2 T = None"
by(rule redT_updT_nta_bisim_inv)
with IH[OF ‹list_all2 (nta_bisim bisim) TAS1 TAS2›, of "redT_updT TS1 TA1" "redT_updT TS2 TA2"] ‹tas2 = TA2 # TAS2›
show ?case by simp
qed
end
lemma tbisim_flip [flip_simps]:
"FWbisimulation_base.tbisim (λt. flip (bisim t)) (flip bisim_wait) w t ts2 m2 ts1 m1 =
FWbisimulation_base.tbisim bisim bisim_wait w t ts1 m1 ts2 m2"
unfolding FWbisimulation_base.tbisim_def flip_simps by auto
lemma mbisim_flip [flip_simps]:
"FWbisimulation_base.mbisim (λt. flip (bisim t)) (flip bisim_wait) s2 s1 =
FWbisimulation_base.mbisim bisim bisim_wait s1 s2"
apply(rule iffI)
apply(frule FWbisimulation_base.mbisim_dom_eq)
apply(frule FWbisimulation_base.mbisim_wset_thread_ok2)
apply(fastforce simp add: FWbisimulation_base.mbisim_def flip_simps)
apply(frule FWbisimulation_base.mbisim_dom_eq)
apply(frule FWbisimulation_base.mbisim_wset_thread_ok2)
apply(fastforce simp add: FWbisimulation_base.mbisim_def flip_simps)
done
lemma mta_bisim_flip [flip_simps]:
"FWbisimulation_base.mta_bisim (λt. flip (bisim t)) = flip (FWbisimulation_base.mta_bisim bisim)"
by(auto simp add: fun_eq_iff flip_simps FWbisimulation_base.mta_bisim_def)
lemma flip_const [simp]: "flip (λa b. c) = (λa b. c)"
by(rule flip_def)
lemma mbisim_K_flip [flip_simps]:
"FWbisimulation_base.mbisim (λt. flip (bisim t)) (λx1 x2. c) s1 s2 =
FWbisimulation_base.mbisim bisim (λx1 x2. c) s2 s1"
using mbisim_flip[of bisim "λx1 x2. c" s1 s2]
unfolding flip_const .
context FWbisimulation_base begin
lemma mbisim_actions_ok_bisim_no_join_12:
assumes mbisim: "mbisim s1 s2"
and "collect_cond_actions ⦃ta1⦄⇘c⇙ = {}"
and "ta_bisim bisim ta1 ta2"
and "r1.actions_ok s1 t ta1"
shows "r2.actions_ok s2 t ta2"
using assms mbisim_thrNone_eq[OF mbisim]
by(auto simp add: ta_bisim_def mbisim_def intro: thread_oks_bisim_inv[THEN iffD1] r2.may_join_cond_action_oks)
lemma mbisim_actions_ok_bisim_no_join_21:
"⟦ mbisim s1 s2; collect_cond_actions ⦃ta2⦄⇘c⇙ = {}; ta_bisim bisim ta1 ta2; r2.actions_ok s2 t ta2 ⟧
⟹ r1.actions_ok s1 t ta1"
using FWbisimulation_base.mbisim_actions_ok_bisim_no_join_12[where bisim="λt. flip (bisim t)" and bisim_wait="flip bisim_wait"]
unfolding flip_simps .
lemma mbisim_actions_ok_bisim_no_join:
"⟦ mbisim s1 s2; collect_cond_actions ⦃ta1⦄⇘c⇙ = {}; ta_bisim bisim ta1 ta2 ⟧
⟹ r1.actions_ok s1 t ta1 = r2.actions_ok s2 t ta2"
apply(rule iffI)
apply(erule (3) mbisim_actions_ok_bisim_no_join_12)
apply(erule mbisim_actions_ok_bisim_no_join_21[where ?ta2.0 = ta2])
apply(simp add: ta_bisim_def)
apply assumption+
done
end
locale FWbisimulation_base_aux = FWbisimulation_base +
r1: multithreaded final1 r1 convert_RA +
r2: multithreaded final2 r2 convert_RA +
constrains final1 :: "'x1 ⇒ bool"
and r1 :: "('l,'t,'x1,'m1,'w, 'o) semantics"
and final2 :: "'x2 ⇒ bool"
and r2 :: "('l,'t,'x2,'m2,'w, 'o) semantics"
and convert_RA :: "'l released_locks ⇒ 'o list"
and bisim :: "'t ⇒ ('x1 × 'm1, 'x2 × 'm2) bisim"
and bisim_wait :: "('x1, 'x2) bisim"
begin
lemma FWbisimulation_base_aux_flip:
"FWbisimulation_base_aux final2 r2 final1 r1"
by(unfold_locales)
end
lemma FWbisimulation_base_aux_flip_simps [flip_simps]:
"FWbisimulation_base_aux final2 r2 final1 r1 = FWbisimulation_base_aux final1 r1 final2 r2"
by(blast intro: FWbisimulation_base_aux.FWbisimulation_base_aux_flip)
sublocale FWbisimulation_base_aux < mthr:
bisimulation_final_base
r1.redT
r2.redT
mbisim
mta_bisim
r1.mfinal
r2.mfinal
.
declare split_paired_Ex [simp del]
subsection ‹Lifting for delay bisimulations›
locale FWdelay_bisimulation_base =
FWbisimulation_base _ _ _ r2 convert_RA bisim bisim_wait +
r1: τmultithreaded final1 r1 convert_RA τmove1 +
r2: τmultithreaded final2 r2 convert_RA τmove2
for r2 :: "('l,'t,'x2,'m2,'w,'o) semantics" ("_ ⊢ _ -2-_→ _" [50,0,0,50] 80)
and convert_RA :: "'l released_locks ⇒ 'o list"
and bisim :: "'t ⇒ ('x1 × 'm1, 'x2 × 'm2) bisim" ("_ ⊢ _/ ≈ _" [50, 50, 50] 60)
and bisim_wait :: "('x1, 'x2) bisim" ("_/ ≈w _" [50, 50] 60)
and τmove1 :: "('l,'t,'x1,'m1,'w,'o) τmoves"
and τmove2 :: "('l,'t,'x2,'m2,'w,'o) τmoves"
begin
abbreviation τmred1 :: "('l,'t,'x1,'m1,'w) state ⇒ ('l,'t,'x1,'m1,'w) state ⇒ bool"
where "τmred1 ≡ r1.τmredT"
abbreviation τmred2 :: "('l,'t,'x2,'m2,'w) state ⇒ ('l,'t,'x2,'m2,'w) state ⇒ bool"
where "τmred2 ≡ r2.τmredT"
abbreviation mτmove1 :: "(('l,'t,'x1,'m1,'w) state, 't × ('l,'t,'x1,'m1,'w,'o) thread_action) trsys"
where "mτmove1 ≡ r1.mτmove"
abbreviation mτmove2 :: "(('l,'t,'x2,'m2,'w) state, 't × ('l,'t,'x2,'m2,'w,'o) thread_action) trsys"
where "mτmove2 ≡ r2.mτmove"
abbreviation τmRed1 :: "('l,'t,'x1,'m1,'w) state ⇒ ('l,'t,'x1,'m1,'w) state ⇒ bool"
where "τmRed1 ≡ τmred1^**"
abbreviation τmRed2 :: "('l,'t,'x2,'m2,'w) state ⇒ ('l,'t,'x2,'m2,'w) state ⇒ bool"
where "τmRed2 ≡ τmred2^**"
abbreviation τmtRed1 :: "('l,'t,'x1,'m1,'w) state ⇒ ('l,'t,'x1,'m1,'w) state ⇒ bool"
where "τmtRed1 ≡ τmred1^++"
abbreviation τmtRed2 :: "('l,'t,'x2,'m2,'w) state ⇒ ('l,'t,'x2,'m2,'w) state ⇒ bool"
where "τmtRed2 ≡ τmred2^++"
lemma bisim_inv_τs1_inv:
assumes inv: "bisim_inv"
and bisim: "t ⊢ s1 ≈ s2"
and red: "r1.silent_moves t s1 s1'"
obtains s2' where "t ⊢ s1' ≈ s2'"
proof(atomize_elim)
from red bisim show "∃s2'. t ⊢ s1' ≈ s2'"
by(induct rule: rtranclp_induct)(fastforce elim: bisim_invD1[OF inv])+
qed
lemma bisim_inv_τs2_inv:
assumes inv: "bisim_inv"
and bisim: "t ⊢ s1 ≈ s2"
and red: "r2.silent_moves t s2 s2'"
obtains s1' where "t ⊢ s1' ≈ s2'"
proof(atomize_elim)
from red bisim show "∃s1'. t ⊢ s1' ≈ s2'"
by(induct rule: rtranclp_induct)(fastforce elim: bisim_invD2[OF inv])+
qed
primrec activate_cond_action1 :: "('l,'t,'x1,'m1,'w) state ⇒ ('l,'t,'x2,'m2,'w) state ⇒
't conditional_action ⇒ ('l,'t,'x1,'m1,'w) state"
where
"activate_cond_action1 s1 s2 (Join t) =
(case thr s1 t of None ⇒ s1
| ⌊(x1, ln1)⌋ ⇒ (case thr s2 t of None ⇒ s1
| ⌊(x2, ln2)⌋ ⇒
if final2 x2 ∧ ln2 = no_wait_locks
then redT_upd_ε s1 t
(SOME x1'. r1.silent_moves t (x1, shr s1) (x1', shr s1) ∧ final1 x1' ∧
t ⊢ (x1', shr s1) ≈ (x2, shr s2))
(shr s1)
else s1))"
| "activate_cond_action1 s1 s2 Yield = s1"
primrec activate_cond_actions1 :: "('l,'t,'x1,'m1,'w) state ⇒ ('l,'t,'x2,'m2,'w) state
⇒ ('t conditional_action) list ⇒ ('l,'t,'x1,'m1,'w) state"
where
"activate_cond_actions1 s1 s2 [] = s1"
| "activate_cond_actions1 s1 s2 (ct # cts) = activate_cond_actions1 (activate_cond_action1 s1 s2 ct) s2 cts"
primrec activate_cond_action2 :: "('l,'t,'x1,'m1,'w) state ⇒ ('l,'t,'x2,'m2,'w) state ⇒
't conditional_action ⇒ ('l,'t,'x2,'m2,'w) state"
where
"activate_cond_action2 s1 s2 (Join t) =
(case thr s2 t of None ⇒ s2
| ⌊(x2, ln2)⌋ ⇒ (case thr s1 t of None ⇒ s2
| ⌊(x1, ln1)⌋ ⇒
if final1 x1 ∧ ln1 = no_wait_locks
then redT_upd_ε s2 t
(SOME x2'. r2.silent_moves t (x2, shr s2) (x2', shr s2) ∧ final2 x2' ∧
t ⊢ (x1, shr s1) ≈ (x2', shr s2))
(shr s2)
else s2))"
| "activate_cond_action2 s1 s2 Yield = s2"
primrec activate_cond_actions2 :: "('l,'t,'x1,'m1,'w) state ⇒ ('l,'t,'x2,'m2,'w) state ⇒
('t conditional_action) list ⇒ ('l,'t,'x2,'m2,'w) state"
where
"activate_cond_actions2 s1 s2 [] = s2"
| "activate_cond_actions2 s1 s2 (ct # cts) = activate_cond_actions2 s1 (activate_cond_action2 s1 s2 ct) cts"
end
lemma activate_cond_action1_flip [flip_simps]:
"FWdelay_bisimulation_base.activate_cond_action1 final2 r2 final1 (λt. flip (bisim t)) τmove2 s2 s1 =
FWdelay_bisimulation_base.activate_cond_action2 final1 final2 r2 bisim τmove2 s1 s2"
apply(rule ext)
apply(case_tac x)
apply(simp_all only: FWdelay_bisimulation_base.activate_cond_action1.simps
FWdelay_bisimulation_base.activate_cond_action2.simps flip_simps)
done
lemma activate_cond_actions1_flip [flip_simps]:
"FWdelay_bisimulation_base.activate_cond_actions1 final2 r2 final1 (λt. flip (bisim t)) τmove2 s2 s1 =
FWdelay_bisimulation_base.activate_cond_actions2 final1 final2 r2 bisim τmove2 s1 s2"
(is "?lhs = ?rhs")
proof(rule ext)
fix xs
show "?lhs xs = ?rhs xs"
by(induct xs arbitrary: s2)
(simp_all only: FWdelay_bisimulation_base.activate_cond_actions1.simps
FWdelay_bisimulation_base.activate_cond_actions2.simps flip_simps)
qed
lemma activate_cond_action2_flip [flip_simps]:
"FWdelay_bisimulation_base.activate_cond_action2 final2 final1 r1 (λt. flip (bisim t)) τmove1 s2 s1 =
FWdelay_bisimulation_base.activate_cond_action1 final1 r1 final2 bisim τmove1 s1 s2"
apply(rule ext)
apply(case_tac x)
apply(simp_all only: FWdelay_bisimulation_base.activate_cond_action1.simps
FWdelay_bisimulation_base.activate_cond_action2.simps flip_simps)
done
lemma activate_cond_actions2_flip [flip_simps]:
"FWdelay_bisimulation_base.activate_cond_actions2 final2 final1 r1 (λt. flip (bisim t)) τmove1 s2 s1 =
FWdelay_bisimulation_base.activate_cond_actions1 final1 r1 final2 bisim τmove1 s1 s2"
(is "?lhs = ?rhs")
proof(rule ext)
fix xs
show "?lhs xs = ?rhs xs"
by(induct xs arbitrary: s1)
(simp_all only: FWdelay_bisimulation_base.activate_cond_actions1.simps
FWdelay_bisimulation_base.activate_cond_actions2.simps flip_simps)
qed
context FWdelay_bisimulation_base begin
lemma shr_activate_cond_action1 [simp]: "shr (activate_cond_action1 s1 s2 ct) = shr s1"
by(cases ct) simp_all
lemma shr_activate_cond_actions1 [simp]: "shr (activate_cond_actions1 s1 s2 cts) = shr s1"
by(induct cts arbitrary: s1) auto
lemma shr_activate_cond_action2 [simp]: "shr (activate_cond_action2 s1 s2 ct) = shr s2"
by(cases ct) simp_all
lemma shr_activate_cond_actions2 [simp]: "shr (activate_cond_actions2 s1 s2 cts) = shr s2"
by(induct cts arbitrary: s2) auto
lemma locks_activate_cond_action1 [simp]: "locks (activate_cond_action1 s1 s2 ct) = locks s1"
by(cases ct) simp_all
lemma locks_activate_cond_actions1 [simp]: "locks (activate_cond_actions1 s1 s2 cts) = locks s1"
by(induct cts arbitrary: s1) auto
lemma locks_activate_cond_action2 [simp]: "locks (activate_cond_action2 s1 s2 ct) = locks s2"
by(cases ct) simp_all
lemma locks_activate_cond_actions2 [simp]: "locks (activate_cond_actions2 s1 s2 cts) = locks s2"
by(induct cts arbitrary: s2) auto
lemma wset_activate_cond_action1 [simp]: "wset (activate_cond_action1 s1 s2 ct) = wset s1"
by(cases ct) simp_all
lemma wset_activate_cond_actions1 [simp]: "wset (activate_cond_actions1 s1 s2 cts) = wset s1"
by(induct cts arbitrary: s1) auto
lemma wset_activate_cond_action2 [simp]: "wset (activate_cond_action2 s1 s2 ct) = wset s2"
by(cases ct) simp_all
lemma wset_activate_cond_actions2 [simp]: "wset (activate_cond_actions2 s1 s2 cts) = wset s2"
by(induct cts arbitrary: s2) auto
lemma interrupts_activate_cond_action1 [simp]: "interrupts (activate_cond_action1 s1 s2 ct) = interrupts s1"
by(cases ct) simp_all
lemma interrupts_activate_cond_actions1 [simp]: "interrupts (activate_cond_actions1 s1 s2 cts) = interrupts s1"
by(induct cts arbitrary: s1) auto
lemma interrupts_activate_cond_action2 [simp]: "interrupts (activate_cond_action2 s1 s2 ct) = interrupts s2"
by(cases ct) simp_all
lemma interrupts_activate_cond_actions2 [simp]: "interrupts (activate_cond_actions2 s1 s2 cts) = interrupts s2"
by(induct cts arbitrary: s2) auto
end
locale FWdelay_bisimulation_lift_aux =
FWdelay_bisimulation_base _ _ _ _ _ _ _ τmove1 τmove2 +
r1: τmultithreaded_wf final1 r1 convert_RA τmove1 +
r2: τmultithreaded_wf final2 r2 convert_RA τmove2
for τmove1 :: "('l,'t,'x1,'m1,'w,'o) τmoves"
and τmove2 :: "('l,'t,'x2,'m2,'w,'o) τmoves"
begin
lemma FWdelay_bisimulation_lift_aux_flip:
"FWdelay_bisimulation_lift_aux final2 r2 final1 r1 τmove2 τmove1"
by unfold_locales
end
lemma FWdelay_bisimulation_lift_aux_flip_simps [flip_simps]:
"FWdelay_bisimulation_lift_aux final2 r2 final1 r1 τmove2 τmove1 =
FWdelay_bisimulation_lift_aux final1 r1 final2 r2 τmove1 τmove2"
by(auto dest: FWdelay_bisimulation_lift_aux.FWdelay_bisimulation_lift_aux_flip simp only: flip_flip)
context FWdelay_bisimulation_lift_aux begin
lemma cond_actions_ok_τmred1_inv:
assumes red: "τmred1 s1 s1'"
and ct: "r1.cond_action_ok s1 t ct"
shows "r1.cond_action_ok s1' t ct"
using ct
proof(cases ct)
case (Join t')
show ?thesis using red ct
proof(cases "thr s1 t'")
case None with red ct Join show ?thesis
by(fastforce elim!: r1.mthr.silent_move.cases r1.redT.cases r1.mτmove.cases rtrancl3p_cases
dest: r1.silent_tl split: if_split_asm)
next
case (Some a) with red ct Join show ?thesis
by(fastforce elim!: r1.mthr.silent_move.cases r1.redT.cases r1.mτmove.cases rtrancl3p_cases
dest: r1.silent_tl r1.final_no_red split: if_split_asm simp add: redT_updWs_def)
qed
next
case Yield thus ?thesis by simp
qed
lemma cond_actions_ok_τmred2_inv:
"⟦ τmred2 s2 s2'; r2.cond_action_ok s2 t ct ⟧ ⟹ r2.cond_action_ok s2' t ct"
using FWdelay_bisimulation_lift_aux.cond_actions_ok_τmred1_inv[OF FWdelay_bisimulation_lift_aux_flip] .
lemma cond_actions_ok_τmRed1_inv:
"⟦ τmRed1 s1 s1'; r1.cond_action_ok s1 t ct ⟧ ⟹ r1.cond_action_ok s1' t ct"
by(induct rule: rtranclp_induct)(blast intro: cond_actions_ok_τmred1_inv)+
lemma cond_actions_ok_τmRed2_inv:
"⟦ τmRed2 s2 s2'; r2.cond_action_ok s2 t ct ⟧ ⟹ r2.cond_action_ok s2' t ct"
by(rule FWdelay_bisimulation_lift_aux.cond_actions_ok_τmRed1_inv[OF FWdelay_bisimulation_lift_aux_flip])
end
locale FWdelay_bisimulation_lift =
FWdelay_bisimulation_lift_aux +
constrains final1 :: "'x1 ⇒ bool"
and r1 :: "('l, 't, 'x1, 'm1, 'w, 'o) semantics"
and final2 :: "'x2 ⇒ bool"
and r2 :: "('l, 't, 'x2, 'm2, 'w, 'o) semantics"
and convert_RA :: "'l released_locks ⇒ 'o list"
and bisim :: "'t ⇒ ('x1 × 'm1, 'x2 × 'm2) bisim"
and bisim_wait :: "('x1, 'x2) bisim"
and τmove1 :: "('l, 't, 'x1, 'm1, 'w, 'o) τmoves"
and τmove2 :: "('l, 't, 'x2, 'm2, 'w, 'o) τmoves"
assumes τinv_locale: "τinv (r1 t) (r2 t) (bisim t) (ta_bisim bisim) τmove1 τmove2"
sublocale FWdelay_bisimulation_lift < τinv "r1 t" "r2 t" "bisim t" "ta_bisim bisim" τmove1 τmove2 for t
by(rule τinv_locale)
context FWdelay_bisimulation_lift begin
lemma FWdelay_bisimulation_lift_flip:
"FWdelay_bisimulation_lift final2 r2 final1 r1 (λt. flip (bisim t)) τmove2 τmove1"
apply(rule FWdelay_bisimulation_lift.intro)
apply(rule FWdelay_bisimulation_lift_aux_flip)
apply(rule FWdelay_bisimulation_lift_axioms.intro)
apply(unfold flip_simps)
apply(unfold_locales)
done
end
lemma FWdelay_bisimulation_lift_flip_simps [flip_simps]:
"FWdelay_bisimulation_lift final2 r2 final1 r1 (λt. flip (bisim t)) τmove2 τmove1 =
FWdelay_bisimulation_lift final1 r1 final2 r2 bisim τmove1 τmove2"
by(auto dest: FWdelay_bisimulation_lift.FWdelay_bisimulation_lift_flip simp only: flip_flip)
context FWdelay_bisimulation_lift begin
lemma τinv_lift: "τinv r1.redT r2.redT mbisim mta_bisim mτmove1 mτmove2"
proof
fix s1 s2 tl1 s1' tl2 s2'
assume "s1 ≈m s2" "s1' ≈m s2'" "tl1 ∼T tl2" "r1.redT s1 tl1 s1'" "r2.redT s2 tl2 s2'"
moreover obtain t ta1 where tl1: "tl1 = (t, ta1)" by(cases tl1)
moreover obtain t' ta2 where tl2: "tl2 = (t', ta2)" by(cases tl2)
moreover obtain ls1 ts1 ws1 m1 is1 where s1: "s1 = (ls1, (ts1, m1), ws1, is1)" by(cases s1) fastforce
moreover obtain ls2 ts2 ws2 m2 is2 where s2: "s2 = (ls2, (ts2, m2), ws2, is2)" by(cases s2) fastforce
moreover obtain ls1' ts1' ws1' m1' is1' where s1': "s1' = (ls1', (ts1', m1'), ws1', is1')" by(cases s1') fastforce
moreover obtain ls2' ts2' ws2' m2' is2' where s2': "s2' = (ls2', (ts2', m2'), ws2', is2')" by(cases s2') fastforce
ultimately have mbisim: "(ls1, (ts1, m1), ws1, is1) ≈m (ls2, (ts2, m2), ws2, is2)"
and mbisim': "(ls1', (ts1', m1'), ws1', is1') ≈m (ls2', (ts2', m2'), ws2', is2')"
and mred1: "(ls1, (ts1, m1), ws1, is1) -1-t▹ta1→ (ls1', (ts1', m1'), ws1', is1')"
and mred2: "(ls2, (ts2, m2), ws2, is2) -2-t▹ta2→ (ls2', (ts2', m2'), ws2', is2')"
and tasim: "ta1 ∼m ta2" and tt': "t' = t" by simp_all
from mbisim have ls: "ls1 = ls2" and ws: "ws1 = ws2" and "is": "is1 = is2"
and tbisim: "⋀t. tbisim (ws2 t = None) t (ts1 t) m1 (ts2 t) m2" by(simp_all add: mbisim_def)
from mbisim' have ls': "ls1' = ls2'" and ws': "ws1' = ws2'" and is': "is1' = is2'"
and tbisim': "⋀t. tbisim (ws2' t = None) t (ts1' t) m1' (ts2' t) m2'" by(simp_all add: mbisim_def)
from mred1 r1.redT_thread_not_disappear[OF mred1]
obtain x1 ln1 x1' ln1' where tst1: "ts1 t = ⌊(x1, ln1)⌋"
and tst1': "ts1' t = ⌊(x1', ln1')⌋"
by(fastforce elim!: r1.redT.cases)
from mred2 r2.redT_thread_not_disappear[OF mred2]
obtain x2 ln2 x2' ln2' where tst2: "ts2 t = ⌊(x2, ln2)⌋"
and tst2': "ts2' t = ⌊(x2', ln2')⌋" by(fastforce elim!: r2.redT.cases)
from tbisim[of t] tst1 tst2 ws have bisim: "t ⊢ (x1, m1) ≈ (x2, m2)"
and ln: "ln1 = ln2" by(auto simp add: tbisim_def)
from tbisim'[of t] tst1' tst2' have bisim': "t ⊢ (x1', m1') ≈ (x2', m2')"
and ln': "ln1' = ln2'" by(auto simp add: tbisim_def)
show "mτmove1 s1 tl1 s1' = mτmove2 s2 tl2 s2'" unfolding s1 s2 s1' s2' tt' tl1 tl2
proof -
show "mτmove1 (ls1, (ts1, m1), ws1, is1) (t, ta1) (ls1', (ts1', m1'), ws1', is1') =
mτmove2 (ls2, (ts2, m2), ws2, is2) (t, ta2) (ls2', (ts2', m2'), ws2', is2')"
(is "?lhs = ?rhs")
proof
assume mτ: ?lhs
with tst1 tst1' obtain τ1: "τmove1 (x1, m1) ta1 (x1', m1')"
and ln1: "ln1 = no_wait_locks" by(fastforce elim!: r1.mτmove.cases)
from τ1 have "ta1 = ε" by(rule r1.silent_tl)
with mred1 τ1 tst1 tst1' ln1 have red1: "t ⊢ (x1, m1) -1-ta1→ (x1', m1')"
by(auto elim!: r1.redT.cases rtrancl3p_cases)
from tasim ‹ta1 = ε› have [simp]: "ta2 = ε" by(simp)
with mred2 ln1 ln tst2 tst2' have red2: "t ⊢ (x2, m2) -2-ε→ (x2', m2')"
by(fastforce elim!: r2.redT.cases rtrancl3p_cases)
from τ1 τinv[OF bisim red1 red2] bisim' tasim
have τ2: "τmove2 (x2, m2) ε (x2', m2')" by simp
with tst2 tst2' ln ln1 show ?rhs by -(rule r2.mτmove.intros, auto)
next
assume mτ: ?rhs
with tst2 tst2' obtain τ2: "τmove2 (x2, m2) ta2 (x2', m2')"
and ln2: "ln2 = no_wait_locks" by(fastforce elim!: r2.mτmove.cases)
from τ2 have "ta2 = ε" by(rule r2.silent_tl)
with mred2 τ2 tst2 tst2' ln2 have red2: "t ⊢ (x2, m2) -2-ta2→ (x2', m2')"
by(auto elim!: r2.redT.cases rtrancl3p_cases)
from tasim ‹ta2 = ε› have [simp]: "ta1 = ε" by simp
with mred1 ln2 ln tst1 tst1' have red1: "t ⊢ (x1, m1) -1-ε→ (x1', m1')"
by(fastforce elim!: r1.redT.cases rtrancl3p_cases)
from τ2 τinv[OF bisim red1 red2] bisim' tasim
have τ1: "τmove1 (x1, m1) ε (x1', m1')" by auto
with tst1 tst1' ln ln2 show ?lhs unfolding ‹ta1 = ε›
by-(rule r1.mτmove.intros, auto)
qed
qed
qed
end
sublocale FWdelay_bisimulation_lift < mthr: τinv r1.redT r2.redT mbisim mta_bisim mτmove1 mτmove2
by(rule τinv_lift)
locale FWdelay_bisimulation_final_base =
FWdelay_bisimulation_lift_aux +
constrains final1 :: "'x1 ⇒ bool"
and r1 :: "('l,'t,'x1,'m1,'w, 'o) semantics"
and final2 :: "'x2 ⇒ bool"
and r2 :: "('l,'t,'x2,'m2,'w, 'o) semantics"
and convert_RA :: "'l released_locks ⇒ 'o list"
and bisim :: "'t ⇒ ('x1 × 'm1, 'x2 × 'm2) bisim"
and bisim_wait :: "('x1, 'x2) bisim"
and τmove1 :: "('l,'t,'x1,'m1,'w, 'o) τmoves"
and τmove2 :: "('l,'t,'x2,'m2,'w, 'o) τmoves"
assumes delay_bisim_locale:
"delay_bisimulation_final_base (r1 t) (r2 t) (bisim t) τmove1 τmove2 (λ(x1, m). final1 x1) (λ(x2, m). final2 x2)"
sublocale FWdelay_bisimulation_final_base <
delay_bisimulation_final_base "r1 t" "r2 t" "bisim t" "ta_bisim bisim" τmove1 τmove2
"λ(x1, m). final1 x1" "λ(x2, m). final2 x2"
for t
by(rule delay_bisim_locale)
context FWdelay_bisimulation_final_base begin
lemma FWdelay_bisimulation_final_base_flip:
"FWdelay_bisimulation_final_base final2 r2 final1 r1 (λt. flip (bisim t)) τmove2 τmove1"
apply(rule FWdelay_bisimulation_final_base.intro)
apply(rule FWdelay_bisimulation_lift_aux_flip)
apply(rule FWdelay_bisimulation_final_base_axioms.intro)
apply(rule delay_bisimulation_final_base_flip)
done
end
lemma FWdelay_bisimulation_final_base_flip_simps [flip_simps]:
"FWdelay_bisimulation_final_base final2 r2 final1 r1 (λt. flip (bisim t)) τmove2 τmove1 =
FWdelay_bisimulation_final_base final1 r1 final2 r2 bisim τmove1 τmove2"
by(auto dest: FWdelay_bisimulation_final_base.FWdelay_bisimulation_final_base_flip simp only: flip_flip)
context FWdelay_bisimulation_final_base begin
lemma cond_actions_ok_bisim_ex_τ1_inv:
fixes ls ts1 m1 ws "is" ts2 m2 ct
defines "s1' ≡ activate_cond_action1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) ct"
assumes mbisim: "⋀t'. t' ≠ t ⟹ tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2"
and ts1t: "ts1 t = Some xln"
and ts2t: "ts2 t = Some xln'"
and ct: "r2.cond_action_ok (ls, (ts2, m2), ws, is) t ct"
shows "τmRed1 (ls, (ts1, m1), ws, is) s1'"
and "⋀t'. t' ≠ t ⟹ tbisim (ws t' = None) t' (thr s1' t') m1 (ts2 t') m2"
and "r1.cond_action_ok s1' t ct"
and "thr s1' t = Some xln"
proof -
have "τmRed1 (ls, (ts1, m1), ws, is) s1' ∧
(∀t'. t' ≠ t ⟶ tbisim (ws t' = None) t' (thr s1' t') m1 (ts2 t') m2) ∧
r1.cond_action_ok s1' t ct ∧ thr s1' t = ⌊xln⌋"
using ct
proof(cases ct)
case (Join t')
show ?thesis
proof(cases "ts1 t'")
case None
with mbisim ts1t have "t ≠ t'" by auto
moreover from None Join have "s1' = (ls, (ts1, m1), ws, is)" by(simp add: s1'_def)
ultimately show ?thesis using mbisim Join ct None ts1t by(simp add: tbisim_def)
next
case (Some xln)
moreover obtain x1 ln where "xln = (x1, ln)" by(cases xln)
ultimately have ts1t': "ts1 t' = ⌊(x1, ln)⌋" by simp
from Join ct Some ts2t have tt': "t' ≠ t" by auto
from mbisim[OF tt'] ts1t' obtain x2 where ts2t': "ts2 t' = ⌊(x2, ln)⌋"
and bisim: "t' ⊢ (x1, m1) ≈ (x2, m2)" by(auto simp add: tbisim_def)
from ct Join ts2t' have final2: "final2 x2" and ln: "ln = no_wait_locks"
and wst': "ws t' = None" by simp_all
let ?x1' = "SOME x. r1.silent_moves t' (x1, m1) (x, m1) ∧ final1 x ∧ t' ⊢ (x, m1) ≈ (x2, m2)"
{ from final2_simulation[OF bisim] final2 obtain x1' m1'
where "r1.silent_moves t' (x1, m1) (x1', m1')" and "t' ⊢ (x1', m1') ≈ (x2, m2)"
and "final1 x1'" by auto
moreover hence "m1' = m1" using bisim by(auto dest: r1.red_rtrancl_τ_heapD_inv)
ultimately have "∃x. r1.silent_moves t' (x1, m1) (x, m1) ∧ final1 x ∧ t' ⊢ (x, m1) ≈ (x2, m2)"
by blast }
from someI_ex[OF this] have red1: "r1.silent_moves t' (x1, m1) (?x1', m1)"
and final1: "final1 ?x1'" and bisim': "t' ⊢ (?x1', m1) ≈ (x2, m2)" by blast+
let ?S1' = "redT_upd_ε (ls, (ts1, m1), ws, is) t' ?x1' m1"
from r1.silent_moves_into_RedT_τ_inv[where ?s="(ls, (ts1, m1), ws, is)" and t=t', simplified, OF red1]
bisim ts1t' ln wst'
have Red1: "τmRed1 (ls, (ts1, m1), ws, is) ?S1'" by auto
moreover from Join ln ts1t' final1 wst' tt'
have ct': "r1.cond_action_ok ?S1' t ct" by(auto intro: finfun_ext)
{ fix t''
assume "t ≠ t''"
with Join mbisim[OF this[symmetric]] bisim' ts1t' ts2t' wst' s1'_def
have "tbisim (ws t'' = None) t'' (thr s1' t'') m1 (ts2 t'') m2"
by(auto simp add: tbisim_def redT_updLns_def o_def finfun_Diag_const2) }
moreover from Join ts1t' ts2t' final2 ln have "s1' = ?S1'" by(simp add: s1'_def)
ultimately show ?thesis using Red1 ct' ts1t' tt' ts1t by(auto)
qed
next
case Yield thus ?thesis using mbisim ts1t by(simp add: s1'_def)
qed
thus "τmRed1 (ls, (ts1, m1), ws, is) s1'"
and "⋀t'. t' ≠ t ⟹ tbisim (ws t' = None) t' (thr s1' t') m1 (ts2 t') m2"
and "r1.cond_action_ok s1' t ct"
and "thr s1' t = ⌊xln⌋" by blast+
qed
lemma cond_actions_oks_bisim_ex_τ1_inv:
fixes ls ts1 m1 ws "is" ts2 m2 cts
defines "s1' ≡ activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) cts"
assumes tbisim: "⋀t'. t' ≠ t ⟹ tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2"
and ts1t: "ts1 t = Some xln"
and ts2t: "ts2 t = Some xln'"
and ct: "r2.cond_action_oks (ls, (ts2, m2), ws, is) t cts"
shows "τmRed1 (ls, (ts1, m1), ws, is) s1'"
and "⋀t'. t' ≠ t ⟹ tbisim (ws t' = None) t' (thr s1' t') m1 (ts2 t') m2"
and "r1.cond_action_oks s1' t cts"
and "thr s1' t = Some xln"
using tbisim ts1t ct unfolding s1'_def
proof(induct cts arbitrary: ts1)
case (Cons ct cts)
note IH1 = ‹⋀ts1. ⟦⋀t'. t' ≠ t ⟹ tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2; ts1 t = ⌊xln⌋;
r2.cond_action_oks (ls, (ts2, m2), ws, is) t cts⟧
⟹ τmred1⇧*⇧* (ls, (ts1, m1), ws, is) (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) cts)›
note IH2 = ‹⋀t' ts1. ⟦t' ≠ t; ⋀t'. t' ≠ t ⟹ tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2; ts1 t = ⌊xln⌋;
r2.cond_action_oks (ls, (ts2, m2), ws, is) t cts⟧
⟹ tbisim (ws t' = None) t' (thr (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) cts) t') m1 (ts2 t') m2›
note IH3 = ‹⋀ts1. ⟦⋀t'. t' ≠ t ⟹ tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2; ts1 t = ⌊xln⌋;
r2.cond_action_oks (ls, (ts2, m2), ws, is) t cts⟧
⟹ r1.cond_action_oks (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) cts) t cts›
note IH4 = ‹⋀ts1. ⟦⋀t'. t' ≠ t ⟹ tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2; ts1 t = ⌊xln⌋;
r2.cond_action_oks (ls, (ts2, m2), ws, is) t cts⟧
⟹ thr (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) cts) t = ⌊xln⌋›
{ fix ts1
assume tbisim: "⋀t'. t' ≠ t ⟹ tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2"
and ts1t: "ts1 t = ⌊xln⌋"
and ct: "r2.cond_action_oks (ls, (ts2, m2), ws, is) t (ct # cts)"
from ct have 1: "r2.cond_action_ok (ls, (ts2, m2), ws, is) t ct"
and 2: "r2.cond_action_oks (ls, (ts2, m2), ws, is) t cts" by auto
let ?s1' = "activate_cond_action1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) ct"
from cond_actions_ok_bisim_ex_τ1_inv[OF tbisim, OF _ ts1t ts2t 1]
have tbisim': "⋀t'. t' ≠ t ⟹ tbisim (ws t' = None) t' (thr ?s1' t') m1 (ts2 t') m2"
and red: "τmRed1 (ls, (ts1, m1), ws, is) ?s1'" and ct': "r1.cond_action_ok ?s1' t ct"
and ts1't: "thr ?s1' t = ⌊xln⌋" by blast+
let ?s1'' = "activate_cond_actions1 ?s1' (ls, (ts2, m2), ws, is) cts"
have "locks ?s1' = ls" "shr ?s1' = m1" "wset ?s1' = ws" "interrupts ?s1' = is" by simp_all
hence s1': "(ls, (thr ?s1', m1), ws, is) = ?s1'" by(cases "?s1'") auto
from IH1[OF tbisim', OF _ ts1't 2] s1' have red': "τmRed1 ?s1' ?s1''" by simp
with red show "τmRed1 (ls, (ts1, m1), ws, is) (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) (ct # cts))"
by auto
{ fix t'
assume t't: "t' ≠ t"
from IH2[OF t't tbisim', OF _ ts1't 2] s1'
show "tbisim (ws t' = None) t' (thr (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) (ct # cts)) t') m1 (ts2 t') m2"
by auto }
from red' ct' have "r1.cond_action_ok ?s1'' t ct" by(rule cond_actions_ok_τmRed1_inv)
with IH3[OF tbisim', OF _ ts1't 2] s1'
show "r1.cond_action_oks (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) (ct # cts)) t (ct # cts)"
by auto
from ts1't IH4[OF tbisim', OF _ ts1't 2] s1'
show "thr (activate_cond_actions1 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) (ct # cts)) t = ⌊xln⌋" by auto }
qed(auto)
lemma cond_actions_ok_bisim_ex_τ2_inv:
fixes ls ts1 m1 "is" ws ts2 m2 ct
defines "s2' ≡ activate_cond_action2 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) ct"
assumes mbisim: "⋀t'. t' ≠ t ⟹ tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2"
and ts1t: "ts1 t = Some xln"
and ts2t: "ts2 t = Some xln'"
and ct: "r1.cond_action_ok (ls, (ts1, m1), ws, is) t ct"
shows "τmRed2 (ls, (ts2, m2), ws, is) s2'"
and "⋀t'. t' ≠ t ⟹ tbisim (ws t' = None) t' (ts1 t') m1 (thr s2' t') m2"
and "r2.cond_action_ok s2' t ct"
and "thr s2' t = Some xln'"
unfolding s2'_def
by(blast intro: FWdelay_bisimulation_final_base.cond_actions_ok_bisim_ex_τ1_inv[OF FWdelay_bisimulation_final_base_flip, where bisim_wait = "flip bisim_wait", unfolded flip_simps, OF mbisim _ _ ct, OF _ ts2t ts1t])+
lemma cond_actions_oks_bisim_ex_τ2_inv:
fixes ls ts1 m1 ws "is" ts2 m2 cts
defines "s2' ≡ activate_cond_actions2 (ls, (ts1, m1), ws, is) (ls, (ts2, m2), ws, is) cts"
assumes tbisim: "⋀t'. t' ≠ t ⟹ tbisim (ws t' = None) t' (ts1 t') m1 (ts2 t') m2"
and ts1t: "ts1 t = Some xln"
and ts2t: "ts2 t = Some xln'"
and ct: "r1.cond_action_oks (ls, (ts1, m1), ws, is) t cts"
shows "τmRed2 (ls, (ts2, m2), ws, is) s2'"
and "⋀t'. t' ≠ t ⟹ tbisim (ws t' = None) t' (ts1 t') m1 (thr s2' t') m2"
and "r2.cond_action_oks s2' t cts"
and "thr s2' t = Some xln'"
unfolding s2'_def
by(blast intro: FWdelay_bisimulation_final_base.cond_actions_oks_bisim_ex_τ1_inv[OF FWdelay_bisimulation_final_base_flip, where bisim_wait = "flip bisim_wait", unfolded flip_simps, OF tbisim _ _ ct, OF _ ts2t ts1t])+
lemma mfinal1_inv_simulation:
assumes "s1 ≈m s2"
shows "∃s2'. r2.mthr.silent_moves s2 s2' ∧ s1 ≈m s2' ∧ r1.final_threads s1 ⊆ r2.final_threads s2' ∧ shr s2' = shr s2"
proof -
from ‹s1 ≈m s2› have "finite (dom (thr s1))" by(auto dest: mbisim_finite1)
moreover have "r1.final_threads s1 ⊆ dom (thr s1)" by(auto simp add: r1.final_thread_def)
ultimately have "finite (r1.final_threads s1)" by(blast intro: finite_subset)
thus ?thesis using ‹s1 ≈m s2›
proof(induct A≡"r1.final_threads s1" arbitrary: s1 s2 rule: finite_induct)
case empty
from ‹{} = r1.final_threads s1›[symmetric] have "∀t. ¬ r1.final_thread s1 t" by(auto)
with ‹s1 ≈m s2› show ?case by blast
next
case (insert t A)
define s1' where "s1' = (locks s1, ((thr s1)(t := None), shr s1), wset s1, interrupts s1)"
define s2' where "s2' = (locks s2, ((thr s2)(t := None), shr s2), wset s2, interrupts s2)"
from ‹t ∉ A› ‹insert t A = r1.final_threads s1› have "A = r1.final_threads s1'"
unfolding s1'_def by(auto simp add: r1.final_thread_def r1.final_threads_def)
moreover from ‹insert t A = r1.final_threads s1› have "r1.final_thread s1 t" by auto
hence "wset s1 t = None" by(auto simp add: r1.final_thread_def)
with ‹s1 ≈m s2› have "s1' ≈m s2'" unfolding s1'_def s2'_def
by(auto simp add: mbisim_def intro: tbisim_NoneI intro!: wset_thread_okI dest: wset_thread_okD split: if_split_asm)
ultimately have "∃s2''. r2.mthr.silent_moves s2' s2'' ∧ s1' ≈m s2'' ∧ r1.final_threads s1' ⊆ r2.final_threads s2'' ∧ shr s2'' = shr s2'" by(rule insert)
then obtain s2'' where reds: "r2.mthr.silent_moves s2' s2''"
and "s1' ≈m s2''" and fin: "⋀t. r1.final_thread s1' t ⟹ r2.final_thread s2'' t" and "shr s2'' = shr s2'" by blast
have "thr s2' t = None" unfolding s2'_def by simp
with ‹r2.mthr.silent_moves s2' s2''›
have "r2.mthr.silent_moves (locks s2', (thr s2'(t ↦ the (thr s2 t)), shr s2'), wset s2', interrupts s2')
(locks s2'', (thr s2''(t ↦ the (thr s2 t)), shr s2''), wset s2'', interrupts s2'')"
by(rule r2.τmRedT_add_thread_inv)
also let ?s2'' = "(locks s2, (thr s2''(t ↦ the (thr s2 t)), shr s2), wset s2, interrupts s2)"
from ‹shr s2'' = shr s2'› ‹s1' ≈m s2''› ‹s1 ≈m s2›
have "(locks s2'', (thr s2''(t ↦ the (thr s2 t)), shr s2''), wset s2'', interrupts s2'') = ?s2''"
unfolding s2'_def s1'_def by(simp add: mbisim_def)
also (back_subst) from ‹s1 ≈m s2› have "dom (thr s1) = dom (thr s2)" by(rule mbisim_dom_eq)
with ‹r1.final_thread s1 t› have "t ∈ dom (thr s2)" by(auto simp add: r1.final_thread_def)
then obtain x2 ln where tst2: "thr s2 t = ⌊(x2, ln)⌋" by auto
hence "(locks s2', (thr s2'(t ↦ the (thr s2 t)), shr s2'), wset s2', interrupts s2') = s2"
unfolding s2'_def by(cases s2)(auto intro!: ext)
also from ‹s1 ≈m s2› tst2 obtain x1
where tst1: "thr s1 t = ⌊(x1, ln)⌋"
and bisim: "t ⊢ (x1, shr s1) ≈ (x2, shr s2)" by(auto dest: mbisim_thrD2)
from ‹shr s2'' = shr s2'› have "shr ?s2'' = shr s2" by(simp add: s2'_def)
from ‹r1.final_thread s1 t› tst1
have final: "final1 x1" "ln = no_wait_locks" "wset s1 t = None" by(auto simp add: r1.final_thread_def)
with final1_simulation[OF bisim] ‹shr ?s2'' = shr s2› obtain x2' m2'
where red: "r2.silent_moves t (x2, shr ?s2'') (x2', m2')"
and bisim': "t ⊢ (x1, shr s1) ≈ (x2', m2')" and "final2 x2'" by auto
from ‹wset s1 t = None› ‹s1 ≈m s2› have "wset s2 t = None" by(simp add: mbisim_def)
with bisim r2.silent_moves_into_RedT_τ_inv[OF red] tst2 ‹ln = no_wait_locks›
have "r2.mthr.silent_moves ?s2'' (redT_upd_ε ?s2'' t x2' m2')" unfolding s2'_def by auto
also (rtranclp_trans)
from bisim r2.red_rtrancl_τ_heapD_inv[OF red] have "m2' = shr s2" by auto
hence "s1 ≈m (redT_upd_ε ?s2'' t x2' m2')"
using ‹s1' ≈m s2''› ‹s1 ≈m s2› tst1 tst2 ‹shr ?s2'' = shr s2› bisim' ‹shr s2'' = shr s2'› ‹wset s2 t = None›
unfolding s1'_def s2'_def by(auto simp add: mbisim_def redT_updLns_def split: if_split_asm intro: tbisim_SomeI)
moreover {
fix t'
assume "r1.final_thread s1 t'"
with fin[of t'] ‹final2 x2'› tst2 ‹ln = no_wait_locks› ‹wset s2 t = None› ‹s1' ≈m s2''› ‹s1 ≈m s2›
have "r2.final_thread (redT_upd_ε ?s2'' t x2' m2') t'" unfolding s1'_def
by(fastforce split: if_split_asm simp add: r2.final_thread_def r1.final_thread_def redT_updLns_def finfun_Diag_const2 o_def mbisim_def)
}
moreover have "shr (redT_upd_ε ?s2'' t x2' m2') = shr s2" using ‹m2' = shr s2› by simp
ultimately show ?case by blast
qed
qed
lemma mfinal2_inv_simulation:
"s1 ≈m s2 ⟹ ∃s1'. r1.mthr.silent_moves s1 s1' ∧ s1' ≈m s2 ∧ r2.final_threads s2 ⊆ r1.final_threads s1' ∧ shr s1' = shr s1"
using FWdelay_bisimulation_final_base.mfinal1_inv_simulation[OF FWdelay_bisimulation_final_base_flip, where bisim_wait="flip bisim_wait"]
by(unfold flip_simps)
lemma mfinal1_simulation:
assumes "s1 ≈m s2" and "r1.mfinal s1"
shows "∃s2'. r2.mthr.silent_moves s2 s2' ∧ s1 ≈m s2' ∧ r2.mfinal s2' ∧ shr s2' = shr s2"
proof -
from mfinal1_inv_simulation[OF ‹s1 ≈m s2›]
obtain s2' where 1: "r2.mthr.silent_moves s2 s2'" "s1 ≈m s2'" "shr s2' = shr s2"
and fin: "⋀t. r1.final_thread s1 t ⟹ r2.final_thread s2' t" by blast
have "r2.mfinal s2'"
proof(rule r2.mfinalI)
fix t x2 ln
assume "thr s2' t = ⌊(x2, ln)⌋"
with ‹s1 ≈m s2'› obtain x1 where "thr s1 t = ⌊(x1, ln)⌋" "t ⊢ (x1, shr s1) ≈ (x2, shr s2')"
by(auto dest: mbisim_thrD2)
from ‹thr s1 t = ⌊(x1, ln)⌋› ‹r1.mfinal s1› have "r1.final_thread s1 t"
by(auto elim!: r1.mfinalE simp add: r1.final_thread_def)
hence "r2.final_thread s2' t" by(rule fin)
thus "final2 x2 ∧ ln = no_wait_locks ∧ wset s2' t = None"
using ‹thr s2' t = ⌊(x2, ln)⌋› by(auto simp add: r2.final_thread_def)
qed
with 1 show ?thesis by blast
qed
lemma mfinal2_simulation:
"⟦ s1 ≈m s2; r2.mfinal s2 ⟧
⟹ ∃s1'. r1.mthr.silent_moves s1 s1' ∧ s1' ≈m s2 ∧ r1.mfinal s1' ∧ shr s1' = shr s1"
using FWdelay_bisimulation_final_base.mfinal1_simulation[OF FWdelay_bisimulation_final_base_flip, where bisim_wait = "flip bisim_wait"]
by(unfold flip_simps)
end
locale FWdelay_bisimulation_obs =
FWdelay_bisimulation_final_base _ _ _ _ _ _ _ τmove1 τmove2
for τmove1 :: "('l,'t,'x1,'m1,'w, 'o) τmoves"
and τmove2 :: "('l,'t,'x2,'m2,'w, 'o) τmoves" +
assumes delay_bisimulation_obs_locale: "delay_bisimulation_obs (r1 t) (r2 t) (bisim t) (ta_bisim bisim) τmove1 τmove2"
and bisim_inv_red_other:
"⟦ t' ⊢ (x, m1) ≈ (xx, m2); t ⊢ (x1, m1) ≈ (x2, m2);
r1.silent_moves t (x1, m1) (x1', m1);
t ⊢ (x1', m1) -1-ta1→ (x1'', m1'); ¬ τmove1 (x1', m1) ta1 (x1'', m1');
r2.silent_moves t (x2, m2) (x2', m2);
t ⊢ (x2', m2) -2-ta2→ (x2'', m2'); ¬ τmove2 (x2', m2) ta2 (x2'', m2');
t ⊢ (x1'', m1') ≈ (x2'', m2'); ta_bisim bisim ta1 ta2 ⟧
⟹ t' ⊢ (x, m1') ≈ (xx, m2')"
and bisim_waitI:
"⟦ t ⊢ (x1, m1) ≈ (x2, m2); r1.silent_moves t (x1, m1) (x1', m1);
t ⊢ (x1', m1) -1-ta1→ (x1'', m1'); ¬ τmove1 (x1', m1) ta1 (x1'', m1');
r2.silent_moves t (x2, m2) (x2', m2);
t ⊢ (x2', m2) -2-ta2→ (x2'', m2'); ¬ τmove2 (x2', m2) ta2 (x2'', m2');
t ⊢ (x1'', m1') ≈ (x2'', m2'); ta_bisim bisim ta1 ta2;
Suspend w ∈ set ⦃ta1⦄⇘w⇙; Suspend w ∈ set ⦃ta2⦄⇘w⇙ ⟧
⟹ x1'' ≈w x2''"
and simulation_Wakeup1:
"⟦ t ⊢ (x1, m1) ≈ (x2, m2); x1 ≈w x2; t ⊢ (x1, m1) -1-ta1→ (x1', m1'); Notified ∈ set ⦃ta1⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta1⦄⇘w⇙ ⟧
⟹ ∃ta2 x2' m2'. t ⊢ (x2, m2) -2-ta2→ (x2', m2') ∧ t ⊢ (x1', m1') ≈ (x2', m2') ∧ ta_bisim bisim ta1 ta2"
and simulation_Wakeup2:
"⟦ t ⊢ (x1, m1) ≈ (x2, m2); x1 ≈w x2; t ⊢ (x2, m2) -2-ta2→ (x2', m2'); Notified ∈ set ⦃ta2⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta2⦄⇘w⇙ ⟧
⟹ ∃ta1 x1' m1'. t ⊢ (x1, m1) -1-ta1→ (x1', m1') ∧ t ⊢ (x1', m1') ≈ (x2', m2') ∧ ta_bisim bisim ta1 ta2"
and ex_final1_conv_ex_final2:
"(∃x1. final1 x1) ⟷ (∃x2. final2 x2)"
sublocale FWdelay_bisimulation_obs <
delay_bisimulation_obs "r1 t" "r2 t" "bisim t" "ta_bisim bisim" τmove1 τmove2 for t
by(rule delay_bisimulation_obs_locale)
context FWdelay_bisimulation_obs begin
lemma FWdelay_bisimulation_obs_flip:
"FWdelay_bisimulation_obs final2 r2 final1 r1 (λt. flip (bisim t)) (flip bisim_wait) τmove2 τmove1"
apply(rule FWdelay_bisimulation_obs.intro)
apply(rule FWdelay_bisimulation_final_base_flip)
apply(rule FWdelay_bisimulation_obs_axioms.intro)
apply(unfold flip_simps)
apply(rule delay_bisimulation_obs_axioms)
apply(erule (9) bisim_inv_red_other)
apply(erule (10) bisim_waitI)
apply(erule (3) simulation_Wakeup2)
apply(erule (3) simulation_Wakeup1)
apply(rule ex_final1_conv_ex_final2[symmetric])
done
end
lemma FWdelay_bisimulation_obs_flip_simps [flip_simps]:
"FWdelay_bisimulation_obs final2 r2 final1 r1 (λt. flip (bisim t)) (flip bisim_wait) τmove2 τmove1 =
FWdelay_bisimulation_obs final1 r1 final2 r2 bisim bisim_wait τmove1 τmove2"
by(auto dest: FWdelay_bisimulation_obs.FWdelay_bisimulation_obs_flip simp only: flip_flip)
context FWdelay_bisimulation_obs begin
lemma mbisim_redT_upd:
fixes s1 t ta1 x1' m1' s2 ta2 x2' m2' ln
assumes s1': "redT_upd s1 t ta1 x1' m1' s1'"
and s2': "redT_upd s2 t ta2 x2' m2' s2'"
and [simp]: "wset s1 = wset s2" "locks s1 = locks s2"
and wset: "wset s1' = wset s2'"
and interrupts: "interrupts s1' = interrupts s2'"
and fin1: "finite (dom (thr s1))"
and wsts: "wset_thread_ok (wset s1) (thr s1)"
and tst: "thr s1 t = ⌊(x1, ln)⌋"
and tst': "thr s2 t = ⌊(x2, ln)⌋"
and aoe1: "r1.actions_ok s1 t ta1"
and aoe2: "r2.actions_ok s2 t ta2"
and tasim: "ta_bisim bisim ta1 ta2"
and bisim': "t ⊢ (x1', m1') ≈ (x2', m2')"
and bisimw: "wset s1' t = None ∨ x1' ≈w x2'"
and τred1: "r1.silent_moves t (x1'', shr s1) (x1, shr s1)"
and red1: "t ⊢ (x1, shr s1) -1-ta1→ (x1', m1')"
and τred2: "r2.silent_moves t (x2'', shr s2) (x2, shr s2)"
and red2: "t ⊢ (x2, shr s2) -2-ta2→ (x2', m2')"
and bisim: "t ⊢ (x1'', shr s1) ≈ (x2'', shr s2)"
and τ1: "¬ τmove1 (x1, shr s1) ta1 (x1', m1')"
and τ2: "¬ τmove2 (x2, shr s2) ta2 (x2', m2')"
and tbisim: "⋀t'. t ≠ t' ⟹ tbisim (wset s1 t' = None) t' (thr s1 t') (shr s1) (thr s2 t') (shr s2)"
shows "s1' ≈m s2'"
proof(rule mbisimI)
from fin1 s1' show "finite (dom (thr s1'))"
by(auto simp add: redT_updTs_finite_dom_inv)
next
from tasim s1' s2' show "locks s1' = locks s2'"
by(auto simp add: redT_updLs_def o_def ta_bisim_def)
next
from wset show "wset s1' = wset s2'" .
next
from interrupts show "interrupts s1' = interrupts s2'" .
next
from wsts s1' s2' wset show "wset_thread_ok (wset s1') (thr s1')"
by(fastforce intro!: wset_thread_okI split: if_split_asm dest: redT_updTs_None wset_thread_okD redT_updWs_None_implies_None)
next
fix T
assume "thr s1' T = None"
moreover with tst s1' have [simp]: "t ≠ T" by auto
from tbisim[OF this] have "(thr s1 T = None) = (thr s2 T = None)"
by(auto simp add: tbisim_def)
hence "(redT_updTs (thr s1) ⦃ta1⦄⇘t⇙ T = None) = (redT_updTs (thr s2) ⦃ta2⦄⇘t⇙ T = None)"
using tasim by -(rule redT_updTs_nta_bisim_inv, simp_all add: ta_bisim_def)
ultimately show "thr s2' T = None" using s2' s1' by(auto split: if_split_asm)
next
fix T X1 LN
assume tsT: "thr s1' T = ⌊(X1, LN)⌋"
show "∃x2. thr s2' T = ⌊(x2, LN)⌋ ∧ T ⊢ (X1, shr s1') ≈ (x2, shr s2') ∧ (wset s2' T = None ∨ X1 ≈w x2)"
proof(cases "thr s1 T")
case None
with tst have "t ≠ T" by auto
with tbisim[OF this] None have tsT': "thr s2 T = None" by(simp add: tbisim_def)
from None ‹t ≠ T› tsT aoe1 s1' obtain M1
where ntset: "NewThread T X1 M1 ∈ set ⦃ta1⦄⇘t⇙" and [simp]: "LN = no_wait_locks"
by(auto dest!: redT_updTs_new_thread)
from ntset obtain tas1 tas1' where "⦃ta1⦄⇘t⇙ = tas1 @ NewThread T X1 M1 # tas1'"
by(auto simp add: in_set_conv_decomp)
with tasim obtain tas2 X2 M2 tas2' where "⦃ta2⦄⇘t⇙ = tas2 @ NewThread T X2 M2 # tas2'"
"length tas2 = length tas2" "length tas1' = length tas2'" and Bisim: "T ⊢ (X1, M1) ≈ (X2, M2)"
by(auto simp add: list_all2_append1 list_all2_Cons1 ta_bisim_def)
hence ntset': "NewThread T X2 M2 ∈ set ⦃ta2⦄⇘t⇙" by auto
with tsT' ‹t ≠ T› aoe2 s2' have "thr s2' T = ⌊(X2, no_wait_locks)⌋"
by(auto intro: redT_updTs_new_thread_ts)
moreover from ntset' red2 have "m2' = M2" by(auto dest: r2.new_thread_memory)
moreover from ntset red1 have "m1' = M1"
by(auto dest: r1.new_thread_memory)
moreover from wsts None have "wset s1 T = None" by(rule wset_thread_okD)
ultimately show ?thesis using Bisim ‹t ≠ T› s1' s2'
by(auto simp add: redT_updWs_None_implies_None)
next
case (Some a)
show ?thesis
proof(cases "t = T")
case True
with tst tsT s1' have [simp]: "X1 = x1'" "LN = redT_updLns (locks s1) t ln ⦃ta1⦄⇘l⇙" by(auto)
show ?thesis using True bisim' bisimw tasim tst tst' s1' s2' wset
by(auto simp add: redT_updLns_def ta_bisim_def)
next
case False
with Some aoe1 tsT s1' have "thr s1 T = ⌊(X1, LN)⌋" by(auto dest: redT_updTs_Some)
with tbisim[OF False] obtain X2
where tsT': "thr s2 T = ⌊(X2, LN)⌋" and Bisim: "T ⊢ (X1, shr s1) ≈ (X2, shr s2)"
and bisimw: "wset s1 T = None ∨ X1 ≈w X2" by(auto simp add: tbisim_def)
with aoe2 False s2' have tsT': "thr s2' T = ⌊(X2, LN)⌋" by(auto simp add: redT_updTs_Some)
moreover from Bisim bisim τred1 red1 τ1 τred2 red2 τ2 bisim' tasim
have "T ⊢ (X1, m1') ≈ (X2, m2')" by(rule bisim_inv_red_other)
ultimately show ?thesis using False bisimw s1' s2'
by(auto simp add: redT_updWs_None_implies_None)
qed
qed
qed
theorem mbisim_simulation1:
assumes mbisim: "mbisim s1 s2" and "¬ mτmove1 s1 tl1 s1'" "r1.redT s1 tl1 s1'"
shows "∃s2' s2'' tl2. r2.mthr.silent_moves s2 s2' ∧ r2.redT s2' tl2 s2'' ∧
¬ mτmove2 s2' tl2 s2'' ∧ mbisim s1' s2'' ∧ mta_bisim tl1 tl2"
proof -
from assms obtain t ta1 where tl1 [simp]: "tl1 = (t, ta1)" and redT: "s1 -1-t▹ta1→ s1'"
and mτ: "¬ mτmove1 s1 (t, ta1) s1'" by(cases tl1) fastforce
obtain ls1 ts1 m1 ws1 is1 where [simp]: "s1 = (ls1, (ts1, m1), ws1, is1)" by(cases s1) fastforce
obtain ls1' ts1' m1' ws1' is1' where [simp]: "s1' = (ls1', (ts1', m1'), ws1', is1')" by(cases s1') fastforce
obtain ls2 ts2 m2 ws2 is2 where [simp]: "s2 = (ls2, (ts2, m2), ws2, is2)" by(cases s2) fastforce
from mbisim have [simp]: "ls2 = ls1" "ws2 = ws1" "is2 = is1" "finite (dom ts1)" by(auto simp add: mbisim_def)
from redT show ?thesis
proof cases
case (redT_normal x1 x1' M1')
hence red: "t ⊢ (x1, m1) -1-ta1→ (x1', M1')"
and tst: "ts1 t = ⌊(x1, no_wait_locks)⌋"
and aoe: "r1.actions_ok s1 t ta1"
and s1': "redT_upd s1 t ta1 x1' M1' s1'" by auto
from mbisim tst obtain x2 where tst': "ts2 t = ⌊(x2, no_wait_locks)⌋"
and bisim: "t ⊢ (x1, m1) ≈ (x2, m2)" by(auto dest: mbisim_thrD1)
from mτ have τ: "¬ τmove1 (x1, m1) ta1 (x1', M1')"
proof(rule contrapos_nn)
assume τ: "τmove1 (x1, m1) ta1 (x1', M1')"
moreover hence [simp]: "ta1 = ε" by(rule r1.silent_tl)
moreover have [simp]: "M1' = m1" by(rule r1.τmove_heap[OF red τ, symmetric])
ultimately show "mτmove1 s1 (t, ta1) s1'" using s1' tst s1'
by(auto simp add: redT_updLs_def o_def intro: r1.mτmove.intros elim: rtrancl3p_cases)
qed
show ?thesis
proof(cases "ws1 t")
case None
note wst = this
from simulation1[OF bisim red τ] obtain x2' M2' x2'' M2'' ta2
where red21: "r2.silent_moves t (x2, m2) (x2', M2')"
and red22: "t ⊢ (x2', M2') -2-ta2→ (x2'', M2'')" and τ2: "¬ τmove2 (x2', M2') ta2 (x2'', M2'')"
and bisim': "t ⊢ (x1', M1') ≈ (x2'', M2'')"
and tasim: "ta_bisim bisim ta1 ta2" by auto
let ?s2' = "redT_upd_ε s2 t x2' M2'"
let ?S2' = "activate_cond_actions2 s1 ?s2' ⦃ta2⦄⇘c⇙"
let ?s2'' = "(redT_updLs (locks ?S2') t ⦃ta2⦄⇘l⇙, ((redT_updTs (thr ?S2') ⦃ta2⦄⇘t⇙)(t ↦ (x2'', redT_updLns (locks ?S2') t (snd (the (thr ?S2' t))) ⦃ta2⦄⇘l⇙)), M2''), wset s1', interrupts s1')"
from red21 tst' wst bisim have "τmRed2 s2 ?s2'"
by -(rule r2.silent_moves_into_RedT_τ_inv, auto)
moreover from red21 bisim have [simp]: "M2' = m2" by(auto dest: r2.red_rtrancl_τ_heapD_inv)
from tasim have [simp]: "⦃ ta1 ⦄⇘l⇙ = ⦃ ta2 ⦄⇘l⇙" "⦃ ta1 ⦄⇘w⇙ = ⦃ ta2 ⦄⇘w⇙" "⦃ ta1 ⦄⇘c⇙ = ⦃ ta2 ⦄⇘c⇙" "⦃ ta1 ⦄⇘i⇙ = ⦃ ta2 ⦄⇘i⇙"
and nta: "list_all2 (nta_bisim bisim) ⦃ ta1 ⦄⇘t⇙ ⦃ ta2 ⦄⇘t⇙" by(auto simp add: ta_bisim_def)
from mbisim have tbisim: "⋀t. tbisim (ws1 t = None) t (ts1 t) m1 (ts2 t) m2" by(simp add: mbisim_def)
hence tbisim': "⋀t'. t' ≠ t ⟹ tbisim (ws1 t' = None) t' (ts1 t') m1 (thr ?s2' t') m2" by(auto)
from aoe have cao1: "r1.cond_action_oks (ls1, (ts1, m1), ws1, is1) t ⦃ta2⦄⇘c⇙" by auto
from tst' have "thr ?s2' t = ⌊(x2', no_wait_locks)⌋" by(auto simp add: redT_updLns_def o_def finfun_Diag_const2)
from cond_actions_oks_bisim_ex_τ2_inv[OF tbisim', OF _ tst this cao1]
have red21': "τmRed2 ?s2' ?S2'" and tbisim'': "⋀t'. t' ≠ t ⟹ tbisim (ws1 t' = None) t' (ts1 t') m1 (thr ?S2' t') m2"
and cao2: "r2.cond_action_oks ?S2' t ⦃ta2⦄⇘c⇙" and tst'': "thr ?S2' t = ⌊(x2', no_wait_locks)⌋"
by(auto simp del: fun_upd_apply)
note red21' also (rtranclp_trans)
from tbisim'' tst'' tst have "∀t'. ts1 t' = None ⟷ thr ?S2' t' = None" by(force simp add: tbisim_def)
from aoe thread_oks_bisim_inv[OF this nta] have "thread_oks (thr ?S2') ⦃ta2⦄⇘t⇙" by simp
with cao2 aoe have aoe': "r2.actions_ok ?S2' t ta2" by auto
with red22 tst'' s1' have "?S2' -2-t▹ta2→ ?s2''"
by -(rule r2.redT.redT_normal, auto)
moreover
from τ2 have "¬ mτmove2 ?S2' (t, ta2) ?s2''"
proof(rule contrapos_nn)
assume mτ: "mτmove2 ?S2' (t, ta2) ?s2''"
thus "τmove2 (x2', M2') ta2 (x2'', M2'')" using tst'' tst'
by cases auto
qed
moreover
{
note s1'
moreover have "redT_upd ?S2' t ta2 x2'' M2'' ?s2''" using s1' by auto
moreover have "wset s1 = wset ?S2'" "locks s1 = locks ?S2'" by simp_all
moreover have "wset s1' = wset ?s2''" by simp
moreover have "interrupts s1' = interrupts ?s2''" by simp
moreover have "finite (dom (thr s1))" by simp
moreover from mbisim have "wset_thread_ok (wset s1) (thr s1)" by(simp add: mbisim_def)
moreover from tst have "thr s1 t = ⌊(x1, no_wait_locks)⌋" by simp
moreover note tst'' aoe aoe' tasim bisim'
moreover have "wset s1' t = None ∨ x1' ≈w x2''"
proof(cases "wset s1' t")
case None thus ?thesis ..
next
case (Some w)
with wst s1' obtain w' where Suspend1: "Suspend w' ∈ set ⦃ta1⦄⇘w⇙"
by(auto dest: redT_updWs_None_SomeD)
with tasim have Suspend2: "Suspend w' ∈ set ⦃ta2⦄⇘w⇙" by(simp add: ta_bisim_def)
from bisim_waitI[OF bisim rtranclp.rtrancl_refl red τ _ _ _ bisim' tasim Suspend1 this, of x2'] red21 red22 τ2
have "x1' ≈w x2''" by auto
thus ?thesis ..
qed
moreover note rtranclp.rtrancl_refl
moreover from red have "t ⊢ (x1, shr s1) -1-ta1→ (x1', M1')" by simp
moreover from red21 have "r2.silent_moves t (x2, shr ?S2') (x2', shr ?S2')" by simp
moreover from red22 have "t ⊢ (x2', shr ?S2') -2-ta2→ (x2'', M2'')" by simp
moreover from bisim have "t ⊢ (x1, shr s1) ≈ (x2, shr ?S2')" by simp
moreover from τ have "¬ τmove1 (x1, shr s1) ta1 (x1', M1')" by simp
moreover from τ2 have "¬ τmove2 (x2', shr ?S2') ta2 (x2'', M2'')" by simp
moreover from tbisim''
have "⋀t'. t ≠ t' ⟹ tbisim (wset s1 t' = None) t' (thr s1 t') (shr s1) (thr ?S2' t') (shr ?S2')"
by simp
ultimately have "mbisim s1' ?s2''" by(rule mbisim_redT_upd)
}
ultimately show ?thesis using tasim unfolding tl1 s1' by fastforce
next
case (Some w)
with mbisim tst tst' have "x1 ≈w x2"
by(auto dest: mbisim_thrD1)
from aoe Some have wakeup: "Notified ∈ set ⦃ta1⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta1⦄⇘w⇙"
by(auto simp add: wset_actions_ok_def split: if_split_asm)
from simulation_Wakeup1[OF bisim ‹x1 ≈w x2› red this]
obtain ta2 x2' m2' where red2: "t ⊢ (x2, m2) -2-ta2→ (x2', m2')"
and bisim': "t ⊢ (x1', M1') ≈ (x2', m2')"
and tasim: "ta1 ∼m ta2" by auto
let ?S2' = "activate_cond_actions2 s1 s2 ⦃ta2⦄⇘c⇙"
let ?s2' = "(redT_updLs (locks ?S2') t ⦃ta2⦄⇘l⇙, ((redT_updTs (thr ?S2') ⦃ta2⦄⇘t⇙)(t ↦ (x2', redT_updLns (locks ?S2') t (snd (the (thr ?S2' t))) ⦃ta2⦄⇘l⇙)), m2'), wset s1', interrupts s1')"
from tasim have [simp]: "⦃ ta1 ⦄⇘l⇙ = ⦃ ta2 ⦄⇘l⇙" "⦃ ta1 ⦄⇘w⇙ = ⦃ ta2 ⦄⇘w⇙" "⦃ ta1 ⦄⇘c⇙ = ⦃ ta2 ⦄⇘c⇙" "⦃ ta1 ⦄⇘i⇙ = ⦃ ta2 ⦄⇘i⇙"
and nta: "list_all2 (nta_bisim bisim) ⦃ ta1 ⦄⇘t⇙ ⦃ ta2 ⦄⇘t⇙" by(auto simp add: ta_bisim_def)
from mbisim have tbisim: "⋀t. tbisim (ws1 t = None) t (ts1 t) m1 (ts2 t) m2" by(simp add: mbisim_def)
hence tbisim': "⋀t'. t' ≠ t ⟹ tbisim (ws1 t' = None) t' (ts1 t') m1 (thr s2 t') m2" by(auto)
from aoe have cao1: "r1.cond_action_oks (ls1, (ts1, m1), ws1, is1) t ⦃ta2⦄⇘c⇙" by auto
from tst' have "thr s2 t = ⌊(x2, no_wait_locks)⌋"
by(auto simp add: redT_updLns_def o_def finfun_Diag_const2)
from cond_actions_oks_bisim_ex_τ2_inv[OF tbisim', OF _ tst this cao1]
have red21': "τmRed2 s2 ?S2'" and tbisim'': "⋀t'. t' ≠ t ⟹ tbisim (ws1 t' = None) t' (ts1 t') m1 (thr ?S2' t') m2"
and cao2: "r2.cond_action_oks ?S2' t ⦃ta2⦄⇘c⇙" and tst'': "thr ?S2' t = ⌊(x2, no_wait_locks)⌋"
by(auto simp del: fun_upd_apply)
note red21' moreover
from tbisim'' tst'' tst have "∀t'. ts1 t' = None ⟷ thr ?S2' t' = None" by(force simp add: tbisim_def)
from aoe thread_oks_bisim_inv[OF this nta] have "thread_oks (thr ?S2') ⦃ta2⦄⇘t⇙" by simp
with cao2 aoe have aoe': "r2.actions_ok ?S2' t ta2" by auto
with red2 tst'' s1' tasim have "?S2' -2-t▹ta2→ ?s2'"
by -(rule r2.redT_normal, auto simp add: ta_bisim_def)
moreover from wakeup tasim
have τ2: "¬ τmove2 (x2, m2) ta2 (x2', m2')" by(auto dest: r2.silent_tl)
hence "¬ mτmove2 ?S2' (t, ta2) ?s2'"
proof(rule contrapos_nn)
assume mτ: "mτmove2 ?S2' (t, ta2) ?s2'"
thus "τmove2 (x2, m2) ta2 (x2', m2')" using tst'' tst'
by cases auto
qed
moreover {
note s1'
moreover have "redT_upd ?S2' t ta2 x2' m2' ?s2'" using s1' tasim by(auto simp add: ta_bisim_def)
moreover have "wset s1 = wset ?S2'" "locks s1 = locks ?S2'" by simp_all
moreover have "wset s1' = wset ?s2'" by simp
moreover have "interrupts s1' = interrupts ?s2'" by simp
moreover have "finite (dom (thr s1))" by simp
moreover from mbisim have "wset_thread_ok (wset s1) (thr s1)" by(rule mbisim_wset_thread_ok1)
moreover from tst have "thr s1 t = ⌊(x1, no_wait_locks)⌋" by simp
moreover from tst'' have "thr ?S2' t = ⌊(x2, no_wait_locks)⌋" by simp
moreover note aoe aoe' tasim bisim'
moreover have "wset s1' t = None ∨ x1' ≈w x2'"
proof(cases "wset s1' t")
case None thus ?thesis ..
next
case (Some w')
with redT_updWs_WokenUp_SuspendD[OF _ wakeup, of t "wset s1" "wset s1'" w'] s1'
obtain w' where Suspend1: "Suspend w' ∈ set ⦃ta1⦄⇘w⇙" by(auto)
with tasim have Suspend2: "Suspend w' ∈ set ⦃ta2⦄⇘w⇙" by(simp add: ta_bisim_def)
with bisim rtranclp.rtrancl_refl red τ rtranclp.rtrancl_refl red2 τ2 bisim' tasim Suspend1
have "x1' ≈w x2'" by(rule bisim_waitI)
thus ?thesis ..
qed
moreover note rtranclp.rtrancl_refl
moreover from red have "t ⊢ (x1, shr s1) -1-ta1→ (x1', M1')" by simp
moreover note rtranclp.rtrancl_refl
moreover from red2 have "t ⊢ (x2, shr ?S2') -2-ta2→ (x2', m2')" by simp
moreover from bisim have "t ⊢ (x1, shr s1) ≈ (x2, shr ?S2')" by simp
moreover from τ have "¬ τmove1 (x1, shr s1) ta1 (x1', M1')" by simp
moreover from τ2 have "¬ τmove2 (x2, shr ?S2') ta2 (x2', m2')" by simp
moreover from tbisim'' have "⋀t'. t ≠ t' ⟹ tbisim (wset s1 t' = None) t' (thr s1 t') (shr s1) (thr ?S2' t') (shr ?S2')" by simp
ultimately have "s1' ≈m ?s2'" by(rule mbisim_redT_upd) }
moreover from tasim have "tl1 ∼T (t, ta2)" by simp
ultimately show ?thesis unfolding s1' by blast
qed
next
case (redT_acquire x1 n ln)
hence [simp]: "ta1 = (K$ [], [], [], [], [], convert_RA ln)"
and tst: "thr s1 t = ⌊(x1, ln)⌋" and wst: "¬ waiting (wset s1 t)"
and maa: "may_acquire_all (locks s1) t ln" and ln: "0 < ln $ n"
and s1': "s1' = (acquire_all ls1 t ln, (ts1(t ↦ (x1, no_wait_locks)), m1), ws1, is1)" by auto
from tst mbisim obtain x2 where tst': "ts2 t = ⌊(x2, ln)⌋"
and bisim: "t ⊢ (x1, m1) ≈ (x2, m2)" by(auto dest: mbisim_thrD1)
let ?s2' = "(acquire_all ls1 t ln, (ts2(t ↦ (x2, no_wait_locks)), m2), ws1, is1)"
from tst' wst maa ln have "s2 -2-t▹(K$ [], [], [], [], [], convert_RA ln)→ ?s2'"
by-(rule r2.redT.redT_acquire, auto)
moreover from tst' ln have "¬ mτmove2 s2 (t, (K$ [], [], [], [], [], convert_RA ln)) ?s2'"
by(auto simp add: acquire_all_def fun_eq_iff elim!: r2.mτmove.cases)
moreover have "mbisim s1' ?s2'"
proof(rule mbisimI)
from s1' show "locks s1' = locks ?s2'" by auto
next
from s1' show "wset s1' = wset ?s2'" by auto
next
from s1' show "interrupts s1' = interrupts ?s2'" by auto
next
fix t' assume "thr s1' t' = None"
with s1' have "thr s1 t' = None" by(auto split: if_split_asm)
with mbisim_thrNone_eq[OF mbisim] have "ts2 t' = None" by simp
with tst' show "thr ?s2' t' = None" by auto
next
fix t' X1 LN
assume ts't: "thr s1' t' = ⌊(X1, LN)⌋"
show "∃x2. thr ?s2' t' = ⌊(x2, LN)⌋ ∧ t' ⊢ (X1, shr s1') ≈ (x2, shr ?s2') ∧ (wset ?s2' t' = None ∨ X1 ≈w x2)"
proof(cases "t' = t")
case True
with s1' tst ts't have [simp]: "X1 = x1" "LN = no_wait_locks" by simp_all
with mbisim_thrD1[OF mbisim tst] bisim tst tst' True s1' wst show ?thesis by(auto)
next
case False
with ts't s1' have "ts1 t' = ⌊(X1, LN)⌋" by auto
with mbisim obtain X2 where "ts2 t' = ⌊(X2, LN)⌋" "t' ⊢ (X1, m1) ≈ (X2, m2)" "wset ?s2' t' = None ∨ X1 ≈w X2"
by(auto dest: mbisim_thrD1)
with False s1' show ?thesis by auto
qed
next
from s1' show "finite (dom (thr s1'))" by auto
next
from mbisim_wset_thread_ok1[OF mbisim]
show "wset_thread_ok (wset s1') (thr s1')" using s1' by(auto intro: wset_thread_ok_upd)
qed
moreover have "(t, K$ [], [], [], [], [], convert_RA ln) ∼T (t, K$ [], [], [], [], [], convert_RA ln)"
by(simp add: ta_bisim_def)
ultimately show ?thesis by fastforce
qed
qed
theorem mbisim_simulation2:
"⟦ mbisim s1 s2; r2.redT s2 tl2 s2'; ¬ mτmove2 s2 tl2 s2' ⟧
⟹ ∃s1' s1'' tl1. r1.mthr.silent_moves s1 s1' ∧ r1.redT s1' tl1 s1'' ∧ ¬ mτmove1 s1' tl1 s1'' ∧
mbisim s1'' s2' ∧ mta_bisim tl1 tl2"
using FWdelay_bisimulation_obs.mbisim_simulation1[OF FWdelay_bisimulation_obs_flip]
unfolding flip_simps .
end
locale FWdelay_bisimulation_diverge =
FWdelay_bisimulation_obs _ _ _ _ _ _ _ τmove1 τmove2
for τmove1 :: "('l,'t,'x1,'m1,'w,'o) τmoves"
and τmove2 :: "('l,'t,'x2,'m2,'w,'o) τmoves" +
assumes delay_bisimulation_diverge_locale: "delay_bisimulation_diverge (r1 t) (r2 t) (bisim t) (ta_bisim bisim) τmove1 τmove2"
sublocale FWdelay_bisimulation_diverge <
delay_bisimulation_diverge "r1 t" "r2 t" "bisim t" "ta_bisim bisim" τmove1 τmove2 for t
by(rule delay_bisimulation_diverge_locale)
context FWdelay_bisimulation_diverge begin
lemma FWdelay_bisimulation_diverge_flip:
"FWdelay_bisimulation_diverge final2 r2 final1 r1 (λt. flip (bisim t)) (flip bisim_wait) τmove2 τmove1"
apply(rule FWdelay_bisimulation_diverge.intro)
apply(rule FWdelay_bisimulation_obs_flip)
apply(rule FWdelay_bisimulation_diverge_axioms.intro)
apply(unfold flip_simps)
apply(rule delay_bisimulation_diverge_axioms)
done
end
lemma FWdelay_bisimulation_diverge_flip_simps [flip_simps]:
"FWdelay_bisimulation_diverge final2 r2 final1 r1 (λt. flip (bisim t)) (flip bisim_wait) τmove2 τmove1 =
FWdelay_bisimulation_diverge final1 r1 final2 r2 bisim bisim_wait τmove1 τmove2"
by(auto dest: FWdelay_bisimulation_diverge.FWdelay_bisimulation_diverge_flip simp only: flip_flip)
context FWdelay_bisimulation_diverge begin
lemma bisim_inv1:
assumes bisim: "t ⊢ s1 ≈ s2"
and red: "t ⊢ s1 -1-ta1→ s1'"
obtains s2' where "t ⊢ s1' ≈ s2'"
proof(atomize_elim)
show "∃s2'. t ⊢ s1' ≈ s2'"
proof(cases "τmove1 s1 ta1 s1'")
case True
with red have "r1.silent_move t s1 s1'" by auto
from simulation_silent1[OF bisim this]
show ?thesis by auto
next
case False
from simulation1[OF bisim red False] show ?thesis by auto
qed
qed
lemma bisim_inv2:
assumes "t ⊢ s1 ≈ s2" "t ⊢ s2 -2-ta2→ s2'"
obtains s1' where "t ⊢ s1' ≈ s2'"
using assms FWdelay_bisimulation_diverge.bisim_inv1[OF FWdelay_bisimulation_diverge_flip]
unfolding flip_simps by blast
lemma bisim_inv: "bisim_inv"
by(blast intro!: bisim_invI elim: bisim_inv1 bisim_inv2)
lemma bisim_inv_τs1:
assumes "t ⊢ s1 ≈ s2" and "r1.silent_moves t s1 s1'"
obtains s2' where "t ⊢ s1' ≈ s2'"
using assms by(rule bisim_inv_τs1_inv[OF bisim_inv])
lemma bisim_inv_τs2:
assumes "t ⊢ s1 ≈ s2" and "r2.silent_moves t s2 s2'"
obtains s1' where "t ⊢ s1' ≈ s2'"
using assms by(rule bisim_inv_τs2_inv[OF bisim_inv])
lemma red1_rtrancl_τ_into_RedT_τ:
assumes "r1.silent_moves t (x1, shr s1) (x1', m1')" "t ⊢ (x1, shr s1) ≈ (x2, m2)"
and "thr s1 t = ⌊(x1, no_wait_locks)⌋" "wset s1 t = None"
shows "τmRed1 s1 (redT_upd_ε s1 t x1' m1')"
using assms by(blast intro: r1.silent_moves_into_RedT_τ_inv)
lemma red2_rtrancl_τ_into_RedT_τ:
assumes "r2.silent_moves t (x2, shr s2) (x2', m2')"
and "t ⊢ (x1, m1) ≈ (x2, shr s2)" "thr s2 t = ⌊(x2, no_wait_locks)⌋" "wset s2 t = None"
shows "τmRed2 s2 (redT_upd_ε s2 t x2' m2')"
using assms by(blast intro: r2.silent_moves_into_RedT_τ_inv)
lemma red1_rtrancl_τ_heapD:
"⟦ r1.silent_moves t s1 s1'; t ⊢ s1 ≈ s2 ⟧ ⟹ snd s1' = snd s1"
by(blast intro: r1.red_rtrancl_τ_heapD_inv)
lemma red2_rtrancl_τ_heapD:
"⟦ r2.silent_moves t s2 s2'; t ⊢ s1 ≈ s2 ⟧ ⟹ snd s2' = snd s2"
by(blast intro: r2.red_rtrancl_τ_heapD_inv)
lemma mbisim_simulation_silent1:
assumes mτ': "r1.mthr.silent_move s1 s1'" and mbisim: "s1 ≈m s2"
shows "∃s2'. r2.mthr.silent_moves s2 s2' ∧ s1' ≈m s2'"
proof -
from mτ' obtain tl1 where mτ: "mτmove1 s1 tl1 s1'" "r1.redT s1 tl1 s1'" by auto
obtain ls1 ts1 m1 ws1 is1 where [simp]: "s1 = (ls1, (ts1, m1), ws1, is1)" by(cases s1) fastforce
obtain ls1' ts1' m1' ws1' is1' where [simp]: "s1' = (ls1', (ts1', m1'), ws1', is1')" by(cases s1') fastforce
obtain ls2 ts2 m2 ws2 is2 where [simp]: "s2 = (ls2, (ts2, m2), ws2, is2)" by(cases s2) fastforce
from mτ obtain t where "tl1 = (t, ε)" by(auto elim!: r1.mτmove.cases dest: r1.silent_tl)
with mτ have mτ: "mτmove1 s1 (t, ε) s1'" and redT1: "s1 -1-t▹ε→ s1'" by simp_all
from mτ obtain x x' ln' where tst: "ts1 t = ⌊(x, no_wait_locks)⌋"
and ts't: "ts1' t = ⌊(x', ln')⌋" and τ: "τmove1 (x, m1) ε (x', m1')"
by(fastforce elim: r1.mτmove.cases)
from mbisim have [simp]: "ls2 = ls1" "ws2 = ws1" "is2 = is1" "finite (dom ts1)" by(auto simp add: mbisim_def)
from redT1 show ?thesis
proof cases
case (redT_normal x1 x1' M')
with tst ts't have [simp]: "x = x1" "x' = x1'"
and red: "t ⊢ (x1, m1) -1-ε→ (x1', M')"
and tst: "thr s1 t = ⌊(x1, no_wait_locks)⌋"
and wst: "wset s1 t = None"
and s1': "redT_upd s1 t ε x1' M' s1'" by(auto)
from s1' tst have [simp]: "ls1' = ls1" "ws1' = ws1" "is1' = is1" "M' = m1'" "ts1' = ts1(t ↦ (x1', no_wait_locks))"
by(auto simp add: redT_updLs_def redT_updLns_def o_def redT_updWs_def elim!: rtrancl3p_cases)
from mbisim tst obtain x2 where tst': "ts2 t = ⌊(x2, no_wait_locks)⌋"
and bisim: "t ⊢ (x1, m1) ≈ (x2, m2)" by(auto dest: mbisim_thrD1)
from r1.τmove_heap[OF red] τ have [simp]: "m1 = M'" by simp
from red τ have "r1.silent_move t (x1, m1) (x1', M')" by auto
from simulation_silent1[OF bisim this]
obtain x2' m2' where red: "r2.silent_moves t (x2, m2) (x2', m2')"
and bisim': "t ⊢ (x1', m1) ≈ (x2', m2')" by auto
from red bisim have [simp]: "m2' = m2"
by(auto dest: red2_rtrancl_τ_heapD)
let ?s2' = "redT_upd_ε s2 t x2' m2'"
from red tst' wst bisim have "τmRed2 s2 ?s2'"
by -(rule red2_rtrancl_τ_into_RedT_τ, auto)
moreover have "mbisim s1' ?s2'"
proof(rule mbisimI)
show "locks s1' = locks ?s2'" "wset s1' = wset ?s2'" "interrupts s1' = interrupts ?s2'" by auto
next
fix t'
assume "thr s1' t' = None"
hence "ts1 t' = None" by(auto split: if_split_asm)
with mbisim_thrNone_eq[OF mbisim] have "ts2 t' = None" by simp
with tst' show "thr ?s2' t' = None" by auto
next
fix t' X1 LN
assume ts't': "thr s1' t' = ⌊(X1, LN)⌋"
show "∃x2. thr ?s2' t' = ⌊(x2, LN)⌋ ∧ t' ⊢ (X1, shr s1') ≈ (x2, shr ?s2') ∧ (wset ?s2' t' = None ∨ X1 ≈w x2)"
proof(cases "t' = t")
case True
note this[simp]
with s1' tst ts't' have [simp]: "X1 = x1'" "LN = no_wait_locks"
by(simp_all)(auto simp add: redT_updLns_def o_def finfun_Diag_const2)
with bisim' tst' wst show ?thesis by(auto simp add: redT_updLns_def o_def finfun_Diag_const2)
next
case False
with ts't' have "ts1 t' = ⌊(X1, LN)⌋" by auto
with mbisim obtain X2 where "ts2 t' = ⌊(X2, LN)⌋" "t' ⊢ (X1, m1) ≈ (X2, m2)" "ws1 t' = None ∨ X1 ≈w X2"
by(auto dest: mbisim_thrD1)
with False show ?thesis by auto
qed
next
show "finite (dom (thr s1'))" by simp
next
from mbisim_wset_thread_ok1[OF mbisim]
show "wset_thread_ok (wset s1') (thr s1')" by(auto intro: wset_thread_ok_upd)
qed
ultimately show ?thesis by(auto)
next
case redT_acquire
with tst have False by auto
thus ?thesis ..
qed
qed
lemma mbisim_simulation_silent2:
"⟦ mbisim s1 s2; r2.mthr.silent_move s2 s2' ⟧
⟹ ∃s1'. r1.mthr.silent_moves s1 s1' ∧ mbisim s1' s2'"
using FWdelay_bisimulation_diverge.mbisim_simulation_silent1[OF FWdelay_bisimulation_diverge_flip]
unfolding flip_simps .
lemma mbisim_simulation1':
assumes mbisim: "mbisim s1 s2" and "¬ mτmove1 s1 tl1 s1'" "r1.redT s1 tl1 s1'"
shows "∃s2' s2'' tl2. r2.mthr.silent_moves s2 s2' ∧ r2.redT s2' tl2 s2'' ∧
¬ mτmove2 s2' tl2 s2'' ∧ mbisim s1' s2'' ∧ mta_bisim tl1 tl2"
using mbisim_simulation1 assms .
lemma mbisim_simulation2':
"⟦ mbisim s1 s2; r2.redT s2 tl2 s2'; ¬ mτmove2 s2 tl2 s2' ⟧
⟹ ∃s1' s1'' tl1. r1.mthr.silent_moves s1 s1' ∧ r1.redT s1' tl1 s1'' ∧ ¬ mτmove1 s1' tl1 s1'' ∧
mbisim s1'' s2' ∧ mta_bisim tl1 tl2"
using FWdelay_bisimulation_diverge.mbisim_simulation1'[OF FWdelay_bisimulation_diverge_flip]
unfolding flip_simps .
lemma mτdiverge_simulation1:
assumes "s1 ≈m s2"
and "r1.mthr.τdiverge s1"
shows "r2.mthr.τdiverge s2"
proof -
from ‹s1 ≈m s2› have "finite (dom (thr s1))"
by(rule mbisim_finite1)+
from r1.τdiverge_τmredTD[OF ‹r1.mthr.τdiverge s1› this]
obtain t x where "thr s1 t = ⌊(x, no_wait_locks)⌋" "wset s1 t = None" "r1.τdiverge t (x, shr s1)" by blast
from ‹s1 ≈m s2› ‹thr s1 t = ⌊(x, no_wait_locks)⌋› obtain x'
where "thr s2 t = ⌊(x', no_wait_locks)⌋" "t ⊢ (x, shr s1) ≈ (x', shr s2)"
by(auto dest: mbisim_thrD1)
from ‹s1 ≈m s2› ‹wset s1 t = None› have "wset s2 t = None" by(simp add: mbisim_def)
from ‹t ⊢ (x, shr s1) ≈ (x', shr s2)› ‹r1.τdiverge t (x, shr s1)›
have "r2.τdiverge t (x', shr s2)" by(simp add: τdiverge_bisim_inv)
thus ?thesis using ‹thr s2 t = ⌊(x', no_wait_locks)⌋› ‹wset s2 t = None›
by(rule r2.τdiverge_into_τmredT)
qed
lemma τdiverge_mbisim_inv:
"s1 ≈m s2 ⟹ r1.mthr.τdiverge s1 ⟷ r2.mthr.τdiverge s2"
apply(rule iffI)
apply(erule (1) mτdiverge_simulation1)
by(rule FWdelay_bisimulation_diverge.mτdiverge_simulation1[OF FWdelay_bisimulation_diverge_flip, unfolded flip_simps])
lemma mbisim_delay_bisimulation:
"delay_bisimulation_diverge r1.redT r2.redT mbisim mta_bisim mτmove1 mτmove2"
apply(unfold_locales)
apply(rule mbisim_simulation1 mbisim_simulation2 mbisim_simulation_silent1 mbisim_simulation_silent2 τdiverge_mbisim_inv|assumption)+
done
theorem mdelay_bisimulation_final_base:
"delay_bisimulation_final_base r1.redT r2.redT mbisim mτmove1 mτmove2 r1.mfinal r2.mfinal"
apply(unfold_locales)
apply(blast dest: mfinal1_simulation mfinal2_simulation)+
done
end
sublocale FWdelay_bisimulation_diverge < mthr: delay_bisimulation_diverge r1.redT r2.redT mbisim mta_bisim mτmove1 mτmove2
by(rule mbisim_delay_bisimulation)
sublocale FWdelay_bisimulation_diverge <
mthr: delay_bisimulation_final_base r1.redT r2.redT mbisim mta_bisim mτmove1 mτmove2 r1.mfinal r2.mfinal
by(rule mdelay_bisimulation_final_base)
context FWdelay_bisimulation_diverge begin
lemma mthr_delay_bisimulation_diverge_final:
"delay_bisimulation_diverge_final r1.redT r2.redT mbisim mta_bisim mτmove1 mτmove2 r1.mfinal r2.mfinal"
by(unfold_locales)
end
sublocale FWdelay_bisimulation_diverge <
mthr: delay_bisimulation_diverge_final r1.redT r2.redT mbisim mta_bisim mτmove1 mτmove2 r1.mfinal r2.mfinal
by(rule mthr_delay_bisimulation_diverge_final)
subsection ‹Strong bisimulation as corollary›
locale FWbisimulation = FWbisimulation_base _ _ _ r2 convert_RA bisim "λx1 x2. True" +
r1: multithreaded final1 r1 convert_RA +
r2: multithreaded final2 r2 convert_RA
for r2 :: "('l,'t,'x2,'m2,'w,'o) semantics" ("_ ⊢ _ -2-_→ _" [50,0,0,50] 80)
and convert_RA :: "'l released_locks ⇒ 'o list"
and bisim :: "'t ⇒ ('x1 × 'm1, 'x2 × 'm2) bisim" ("_ ⊢ _/ ≈ _" [50, 50, 50] 60) +
assumes bisimulation_locale: "bisimulation (r1 t) (r2 t) (bisim t) (ta_bisim bisim)"
and bisim_final: "t ⊢ (x1, m1) ≈ (x2, m2) ⟹ final1 x1 ⟷ final2 x2"
and bisim_inv_red_other:
"⟦ t' ⊢ (x, m1) ≈ (xx, m2); t ⊢ (x1, m1) ≈ (x2, m2);
t ⊢ (x1, m1) -1-ta1→ (x1', m1'); t ⊢ (x2, m2) -2-ta2→ (x2', m2');
t ⊢ (x1', m1') ≈ (x2', m2'); ta_bisim bisim ta1 ta2 ⟧
⟹ t' ⊢ (x, m1') ≈ (xx, m2')"
and ex_final1_conv_ex_final2:
"(∃x1. final1 x1) ⟷ (∃x2. final2 x2)"
sublocale FWbisimulation < bisim?: bisimulation "r1 t" "r2 t" "bisim t" "ta_bisim bisim" for t
by(rule bisimulation_locale)
sublocale FWbisimulation < bisim_diverge?:
FWdelay_bisimulation_diverge final1 r1 final2 r2 convert_RA bisim "λx1 x2. True" "λs ta s'. False" "λs ta s'. False"
proof -
interpret biw: bisimulation_into_delay "r1 t" "r2 t" "bisim t" "ta_bisim bisim" "λs ta s'. False" "λs ta s'. False"
for t
by(unfold_locales) simp
show "FWdelay_bisimulation_diverge final1 r1 final2 r2 bisim (λx1 x2. True) (λs ta s'. False) (λs ta s'. False)"
proof(unfold_locales)
fix t' x m1 xx m2 x1 x2 t x1' ta1 x1'' m1' x2' ta2 x2'' m2'
assume bisim: "t' ⊢ (x, m1) ≈ (xx, m2)" and bisim12: "t ⊢ (x1, m1) ≈ (x2, m2)"
and τ1: "τtrsys.silent_moves (r1 t) (λs ta s'. False) (x1, m1) (x1', m1)"
and red1: "t ⊢ (x1', m1) -1-ta1→ (x1'', m1')"
and τ2: "τtrsys.silent_moves (r2 t) (λs ta s'. False) (x2, m2) (x2', m2)"
and red2: "t ⊢ (x2', m2) -2-ta2→ (x2'', m2')"
and bisim12': "t ⊢ (x1'', m1') ≈ (x2'', m2')" and tasim: "ta1 ∼m ta2"
from τ1 τ2 have [simp]: "x1' = x1" "x2' = x2" by(simp_all add: rtranclp_False τmoves_False)
from bisim12 bisim_inv_red_other[OF bisim _ red1 red2 bisim12' tasim]
show "t' ⊢ (x, m1') ≈ (xx, m2')" by simp
next
fix t x1 m1 x2 m2 ta1 x1' m1'
assume "t ⊢ (x1, m1) ≈ (x2, m2)" "t ⊢ (x1, m1) -1-ta1→ (x1', m1')"
from simulation1[OF this]
show "∃ta2 x2' m2'. t ⊢ (x2, m2) -2-ta2→ (x2', m2') ∧ t ⊢ (x1', m1') ≈ (x2', m2') ∧ ta1 ∼m ta2"
by auto
next
fix t x1 m1 x2 m2 ta2 x2' m2'
assume "t ⊢ (x1, m1) ≈ (x2, m2)" "t ⊢ (x2, m2) -2-ta2→ (x2', m2')"
from simulation2[OF this]
show "∃ta1 x1' m1'. t ⊢ (x1, m1) -1-ta1→ (x1', m1') ∧ t ⊢ (x1', m1') ≈ (x2', m2') ∧ ta1 ∼m ta2"
by auto
next
show "(∃x1. final1 x1) ⟷ (∃x2. final2 x2)" by(rule ex_final1_conv_ex_final2)
qed(fastforce simp add: bisim_final)+
qed
context FWbisimulation begin
lemma FWbisimulation_flip: "FWbisimulation final2 r2 final1 r1 (λt. flip (bisim t))"
apply(rule FWbisimulation.intro)
apply(rule r2.multithreaded_axioms)
apply(rule r1.multithreaded_axioms)
apply(rule FWbisimulation_axioms.intro)
apply(unfold flip_simps)
apply(rule bisimulation_axioms)
apply(erule bisim_final[symmetric])
apply(erule (5) bisim_inv_red_other)
apply(rule ex_final1_conv_ex_final2[symmetric])
done
end
lemma FWbisimulation_flip_simps [flip_simps]:
"FWbisimulation final2 r2 final1 r1 (λt. flip (bisim t)) = FWbisimulation final1 r1 final2 r2 bisim"
by(auto dest: FWbisimulation.FWbisimulation_flip simp only: flip_flip)
context FWbisimulation begin
text ‹
The notation for mbisim is lost because @{term "bisim_wait"} is instantiated to @{term "λx1 x2. True"}.
This reintroduces the syntax, but it does not work for output mode. This would require a new abbreviation.
›
notation mbisim ("_ ≈m _" [50, 50] 60)
theorem mbisim_bisimulation:
"bisimulation r1.redT r2.redT mbisim mta_bisim"
proof
fix s1 s2 tta1 s1'
assume mbisim: "s1 ≈m s2" and "r1.redT s1 tta1 s1'"
from mthr.simulation1[OF this]
show "∃s2' tta2. r2.redT s2 tta2 s2' ∧ s1' ≈m s2' ∧ tta1 ∼T tta2"
by(auto simp add: τmoves_False mτmove_False)
next
fix s2 s1 tta2 s2'
assume "s1 ≈m s2" and "r2.redT s2 tta2 s2'"
from mthr.simulation2[OF this]
show "∃s1' tta1. r1.redT s1 tta1 s1' ∧ s1' ≈m s2' ∧ tta1 ∼T tta2"
by(auto simp add: τmoves_False mτmove_False)
qed
lemma mbisim_wset_eq:
"s1 ≈m s2 ⟹ wset s1 = wset s2"
by(simp add: mbisim_def)
lemma mbisim_mfinal:
"s1 ≈m s2 ⟹ r1.mfinal s1 ⟷ r2.mfinal s2"
apply(auto intro!: r2.mfinalI r1.mfinalI dest: mbisim_thrD2 mbisim_thrD1 bisim_final elim: r1.mfinalE r2.mfinalE)
apply(frule (1) mbisim_thrD2, drule mbisim_wset_eq, auto elim: r1.mfinalE)
apply(frule (1) mbisim_thrD1, drule mbisim_wset_eq, auto elim: r2.mfinalE)
done
end
sublocale FWbisimulation < mthr: bisimulation r1.redT r2.redT mbisim mta_bisim
by(rule mbisim_bisimulation)
sublocale FWbisimulation < mthr: bisimulation_final r1.redT r2.redT mbisim mta_bisim r1.mfinal r2.mfinal
by(unfold_locales)(rule mbisim_mfinal)
end
Theory FWBisimDeadlock
section ‹Preservation of deadlock across bisimulations›
theory FWBisimDeadlock
imports
FWBisimulation
FWDeadlock
begin
context FWdelay_bisimulation_obs begin
lemma actions_ok1_ex_actions_ok2:
assumes "r1.actions_ok s1 t ta1"
and "ta1 ∼m ta2"
obtains s2 where "r2.actions_ok s2 t ta2"
proof -
let ?s2 = "(locks s1, (λt. map_option (λ(x1, ln). (SOME x2. if final1 x1 then final2 x2 else ¬ final2 x2, ln)) (thr s1 t), undefined), wset s1, interrupts s1)"
from ‹ta1 ∼m ta2› have "⦃ta1⦄⇘c⇙ = ⦃ta2⦄⇘c⇙" by(simp add: ta_bisim_def)
with ‹r1.actions_ok s1 t ta1› have cao1: "r1.cond_action_oks s1 t ⦃ta2⦄⇘c⇙" by auto
have "r2.cond_action_oks ?s2 t ⦃ta2⦄⇘c⇙" unfolding r2.cond_action_oks_conv_set
proof
fix ct
assume "ct ∈ set ⦃ta2⦄⇘c⇙"
with cao1 have "r1.cond_action_ok s1 t ct"
unfolding r1.cond_action_oks_conv_set by auto
thus "r2.cond_action_ok ?s2 t ct" using ex_final1_conv_ex_final2
by(cases ct)(fastforce intro: someI_ex[where P=final2])+
qed
hence "r2.actions_ok ?s2 t ta2"
using assms by(auto simp add: ta_bisim_def split del: if_split elim: rev_iffD1[OF _ thread_oks_bisim_inv])
thus thesis by(rule that)
qed
lemma actions_ok2_ex_actions_ok1:
assumes "r2.actions_ok s2 t ta2"
and "ta1 ∼m ta2"
obtains s1 where "r1.actions_ok s1 t ta1"
using FWdelay_bisimulation_obs.actions_ok1_ex_actions_ok2[OF FWdelay_bisimulation_obs_flip] assms
unfolding flip_simps .
lemma ex_actions_ok1_conv_ex_actions_ok2:
"ta1 ∼m ta2 ⟹ (∃s1. r1.actions_ok s1 t ta1) ⟷ (∃s2. r2.actions_ok s2 t ta2)"
by(metis actions_ok1_ex_actions_ok2 actions_ok2_ex_actions_ok1)
end
context FWdelay_bisimulation_diverge begin
lemma no_τMove1_τs_to_no_τMove2:
fixes no_τmoves1 no_τmoves2
defines "no_τmoves1 ≡ λs1 t. wset s1 t = None ∧ (∃x. thr s1 t = ⌊(x, no_wait_locks)⌋ ∧ (∀x' m'. ¬ r1.silent_move t (x, shr s1) (x', m')))"
defines "no_τmoves2 ≡ λs2 t. wset s2 t = None ∧ (∃x. thr s2 t = ⌊(x, no_wait_locks)⌋ ∧ (∀x' m'. ¬ r2.silent_move t (x, shr s2) (x', m')))"
assumes mbisim: "s1 ≈m (ls2, (ts2, m2), ws2, is2)"
shows "∃ts2'. r2.mthr.silent_moves (ls2, (ts2, m2), ws2, is2) (ls2, (ts2', m2), ws2, is2) ∧
(∀t. no_τmoves1 s1 t ⟶ no_τmoves2 (ls2, (ts2', m2), ws2, is2) t) ∧ s1 ≈m (ls2, (ts2', m2), ws2, is2)"
proof -
from mbisim have "finite (dom (thr s1))" by(simp add: mbisim_def)
hence "finite {t. no_τmoves1 s1 t}" unfolding no_τmoves1_def
by-(rule finite_subset, auto)
thus ?thesis using ‹s1 ≈m (ls2, (ts2, m2), ws2, is2)›
proof(induct A≡"{t. no_τmoves1 s1 t}" arbitrary: s1 ts2 rule: finite_induct)
case empty
from ‹{} = {t. no_τmoves1 s1 t}›[symmetric] have "no_τmoves1 s1 = (λt. False)"
by(auto intro: ext)
thus ?case using ‹s1 ≈m (ls2, (ts2, m2), ws2, is2)› by auto
next
case (insert t A)
note mbisim = ‹s1 ≈m (ls2, (ts2, m2), ws2, is2)›
from ‹insert t A = {t. no_τmoves1 s1 t}›
have "no_τmoves1 s1 t" by auto
then obtain x1 where ts1t: "thr s1 t = ⌊(x1, no_wait_locks)⌋"
and ws1t: "wset s1 t = None"
and τ1: "⋀x1m1'. ¬ r1.silent_move t (x1, shr s1) x1m1'"
by(auto simp add: no_τmoves1_def)
from ts1t mbisim obtain x2 where ts2t: "ts2 t = ⌊(x2, no_wait_locks)⌋"
and "t ⊢ (x1, shr s1) ≈ (x2, m2)" by(auto dest: mbisim_thrD1)
from mbisim ws1t have "ws2 t = None" by(simp add: mbisim_def)
let ?s1 = "(locks s1, ((thr s1)(t := None), shr s1), wset s1, interrupts s1)"
let ?s2 = "(ls2, (ts2(t := None), m2), ws2, is2)"
from ‹insert t A = {t. no_τmoves1 s1 t}› ‹t ∉ A›
have A: "A = {t. no_τmoves1 ?s1 t}" by(auto simp add: no_τmoves1_def)
have "?s1 ≈m ?s2"
proof(rule mbisimI)
from mbisim
show "finite (dom (thr ?s1))" "locks ?s1 = locks ?s2" "wset ?s1 = wset ?s2" "interrupts ?s1 = interrupts ?s2"
by(simp_all add: mbisim_def)
next
from mbisim_wset_thread_ok1[OF mbisim] ws1t show "wset_thread_ok (wset ?s1) (thr ?s1)"
by(auto intro!: wset_thread_okI dest: wset_thread_okD split: if_split_asm)
next
fix t'
assume "thr ?s1 t' = None"
with mbisim_thrNone_eq[OF mbisim, of t']
show "thr ?s2 t' = None" by auto
next
fix t' x1 ln
assume "thr ?s1 t' = ⌊(x1, ln)⌋"
hence "thr s1 t' = ⌊(x1, ln)⌋" "t' ≠ t" by(auto split: if_split_asm)
with mbisim_thrD1[OF mbisim ‹thr s1 t' = ⌊(x1, ln)⌋›] mbisim
show "∃x2. thr ?s2 t' = ⌊(x2, ln)⌋ ∧ t' ⊢ (x1, shr ?s1) ≈ (x2, shr ?s2) ∧ (wset ?s2 t' = None ∨ x1 ≈w x2)"
by(auto simp add: mbisim_def)
qed
with A have "∃ts2'. r2.mthr.silent_moves ?s2 (ls2, (ts2', m2), ws2, is2) ∧ (∀t. no_τmoves1 ?s1 t ⟶ no_τmoves2 (ls2, (ts2', m2), ws2, is2) t) ∧ ?s1 ≈m (ls2, (ts2', m2), ws2, is2)" by(rule insert)
then obtain ts2' where "r2.mthr.silent_moves ?s2 (ls2, (ts2', m2), ws2, is2)"
and no_τ: "⋀t. no_τmoves1 ?s1 t ⟹ no_τmoves2 (ls2, (ts2', m2), ws2, is2) t"
and "?s1 ≈m (ls2, (ts2', m2), ws2, is2)" by auto
let ?s2' = "(ls2, (ts2'(t ↦ (x2, no_wait_locks)), m2), ws2, is2)"
from ts2t have "ts2(t ↦ (x2, no_wait_locks)) = ts2" by(auto intro: ext)
with r2.τmRedT_add_thread_inv[OF ‹r2.mthr.silent_moves ?s2 (ls2, (ts2', m2), ws2, is2)›, of t "(x2, no_wait_locks)"]
have "r2.mthr.silent_moves (ls2, (ts2, m2), ws2, is2) ?s2'" by simp
from no_τmove1_τs_to_no_τmove2[OF ‹t ⊢ (x1, shr s1) ≈ (x2, m2)› τ1]
obtain x2' m2' where "r2.silent_moves t (x2, m2) (x2', m2')"
and "⋀x2'' m2''. ¬ r2.silent_move t (x2', m2') (x2'', m2'')"
and "t ⊢ (x1, shr s1) ≈ (x2', m2')" by auto
let ?s2'' = "(ls2, (ts2'(t ↦ (x2', no_wait_locks)), m2'), ws2, is2)"
from red2_rtrancl_τ_heapD[OF ‹r2.silent_moves t (x2, m2) (x2', m2')› ‹t ⊢ (x1, shr s1) ≈ (x2, m2)›]
have "m2' = m2" by simp
with ‹r2.silent_moves t (x2, m2) (x2', m2')› have "r2.silent_moves t (x2, shr ?s2') (x2', m2)" by simp
hence "r2.mthr.silent_moves ?s2' (redT_upd_ε ?s2' t x2' m2)"
by(rule red2_rtrancl_τ_into_RedT_τ)(auto simp add: ‹ws2 t = None› intro: ‹t ⊢ (x1, shr s1) ≈ (x2, m2)›)
also have "redT_upd_ε ?s2' t x2' m2 = ?s2''" using ‹m2' = m2›
by(auto simp add: fun_eq_iff redT_updLns_def finfun_Diag_const2 o_def)
finally (back_subst) have "r2.mthr.silent_moves (ls2, (ts2, m2), ws2, is2) ?s2''"
using ‹r2.mthr.silent_moves (ls2, (ts2, m2), ws2, is2) ?s2'› by-(rule rtranclp_trans)
moreover {
fix t'
assume no_τ1: "no_τmoves1 s1 t'"
have "no_τmoves2 ?s2'' t'"
proof(cases "t' = t")
case True thus ?thesis
using ‹ws2 t = None› ‹⋀x2'' m2''. ¬ r2.silent_move t (x2', m2') (x2'', m2'')› by(simp add: no_τmoves2_def)
next
case False
with no_τ1 have "no_τmoves1 ?s1 t'" by(simp add: no_τmoves1_def)
hence "no_τmoves2 (ls2, (ts2', m2), ws2, is2) t'"
by(rule ‹no_τmoves1 ?s1 t' ⟹ no_τmoves2 (ls2, (ts2', m2), ws2, is2) t'›)
with False ‹m2' = m2› show ?thesis by(simp add: no_τmoves2_def)
qed }
moreover have "s1 ≈m ?s2''"
proof(rule mbisimI)
from mbisim
show "finite (dom (thr s1))" "locks s1 = locks ?s2''" "wset s1 = wset ?s2''" "interrupts s1 = interrupts ?s2''"
by(simp_all add: mbisim_def)
next
from mbisim show "wset_thread_ok (wset s1) (thr s1)" by(rule mbisim_wset_thread_ok1)
next
fix t'
assume "thr s1 t' = None"
hence "thr ?s1 t' = None" "t' ≠ t" using ts1t by auto
with mbisim_thrNone_eq[OF ‹?s1 ≈m (ls2, (ts2', m2), ws2, is2)›, of t']
show "thr ?s2'' t' = None" by simp
next
fix t' x1' ln'
assume "thr s1 t' = ⌊(x1', ln')⌋"
show "∃x2. thr ?s2'' t' = ⌊(x2, ln')⌋ ∧ t' ⊢ (x1', shr s1) ≈ (x2, shr ?s2'') ∧ (wset ?s2'' t' = None ∨ x1' ≈w x2)"
proof(cases "t = t'")
case True
with ‹thr s1 t' = ⌊(x1', ln')⌋› ts1t ‹t ⊢ (x1, shr s1) ≈ (x2', m2')› ‹m2' = m2› ‹ws2 t = None›
show ?thesis by auto
next
case False
with mbisim_thrD1[OF ‹?s1 ≈m (ls2, (ts2', m2), ws2, is2)›, of t' x1' ln'] ‹thr s1 t' = ⌊(x1', ln')⌋› ‹m2' = m2› mbisim
show ?thesis by(auto simp add: mbisim_def)
qed
qed
ultimately show ?case unfolding ‹m2' = m2› by blast
qed
qed
lemma no_τMove2_τs_to_no_τMove1:
fixes no_τmoves1 no_τmoves2
defines "no_τmoves1 ≡ λs1 t. wset s1 t = None ∧ (∃x. thr s1 t = ⌊(x, no_wait_locks)⌋ ∧ (∀x' m'. ¬ r1.silent_move t (x, shr s1) (x', m')))"
defines "no_τmoves2 ≡ λs2 t. wset s2 t = None ∧ (∃x. thr s2 t = ⌊(x, no_wait_locks)⌋ ∧ (∀x' m'. ¬ r2.silent_move t (x, shr s2) (x', m')))"
assumes "(ls1, (ts1, m1), ws1, is1) ≈m s2"
shows "∃ts1'. r1.mthr.silent_moves (ls1, (ts1, m1), ws1, is1) (ls1, (ts1', m1), ws1, is1) ∧
(∀t. no_τmoves2 s2 t ⟶ no_τmoves1 (ls1, (ts1', m1), ws1, is1) t) ∧ (ls1, (ts1', m1), ws1, is1) ≈m s2"
using assms FWdelay_bisimulation_diverge.no_τMove1_τs_to_no_τMove2[OF FWdelay_bisimulation_diverge_flip]
unfolding flip_simps by blast
lemma deadlock_mbisim_not_final_thread_pres:
assumes dead: "t ∈ r1.deadlocked s1 ∨ r1.deadlock s1"
and nfin: "r1.not_final_thread s1 t"
and fin: "r1.final_thread s1 t ⟹ r2.final_thread s2 t"
and mbisim: "s1 ≈m s2"
shows "r2.not_final_thread s2 t"
proof -
from nfin obtain x1 ln where "thr s1 t = ⌊(x1, ln)⌋" by cases auto
with mbisim obtain x2 where "thr s2 t = ⌊(x2, ln)⌋" "t ⊢ (x1, shr s1) ≈ (x2, shr s2)" "wset s1 t = None ∨ x1 ≈w x2"
by(auto dest: mbisim_thrD1)
show "r2.not_final_thread s2 t"
proof(cases "wset s1 t = None ∧ ln = no_wait_locks")
case False
with ‹r1.not_final_thread s1 t› ‹thr s1 t = ⌊(x1, ln)⌋› ‹thr s2 t = ⌊(x2, ln)⌋› mbisim
show ?thesis by cases(auto simp add: mbisim_def r2.not_final_thread_iff)
next
case True
with ‹r1.not_final_thread s1 t› ‹thr s1 t = ⌊(x1, ln)⌋› have "¬ final1 x1" by(cases) auto
have "¬ final2 x2"
proof
assume "final2 x2"
with final2_simulation[OF ‹t ⊢ (x1, shr s1) ≈ (x2, shr s2)›]
obtain x1' m1' where "r1.silent_moves t (x1, shr s1) (x1', m1')" "t ⊢ (x1', m1') ≈ (x2, shr s2)" "final1 x1'" by auto
from ‹r1.silent_moves t (x1, shr s1) (x1', m1')› have "x1' = x1"
proof(cases rule: converse_rtranclpE2[consumes 1, case_names refl step])
case (step x1'' m1'')
from ‹r1.silent_move t (x1, shr s1) (x1'', m1'')›
have "t ⊢ (x1, shr s1) -1-ε→ (x1'', m1'')" by(auto dest: r1.silent_tl)
hence "r1.redT s1 (t, ε) (redT_upd_ε s1 t x1'' m1'')"
using ‹thr s1 t = ⌊(x1, ln)⌋› True
by -(erule r1.redT_normal, auto simp add: redT_updLns_def finfun_Diag_const2 o_def redT_updWs_def)
hence False using dead by(auto intro: r1.deadlock_no_red r1.red_no_deadlock)
thus ?thesis ..
qed simp
with ‹¬ final1 x1› ‹final1 x1'› show False by simp
qed
thus ?thesis using ‹thr s2 t = ⌊(x2, ln)⌋› by(auto simp add: r2.not_final_thread_iff)
qed
qed
lemma deadlocked1_imp_τs_deadlocked2:
assumes mbisim: "s1 ≈m s2"
and dead: "t ∈ r1.deadlocked s1"
shows "∃s2'. r2.mthr.silent_moves s2 s2' ∧ t ∈ r2.deadlocked s2' ∧ s1 ≈m s2'"
proof -
from mfinal1_inv_simulation[OF mbisim]
obtain ls2 ts2 m2 ws2 is2 where red1: "r2.mthr.silent_moves s2 (ls2, (ts2, m2), ws2, is2)"
and "s1 ≈m (ls2, (ts2, m2), ws2, is2)" and "m2 = shr s2"
and fin: "⋀t. r1.final_thread s1 t ⟹ r2.final_thread (ls2, (ts2, m2), ws2, is2) t" by fastforce
from no_τMove1_τs_to_no_τMove2[OF ‹s1 ≈m (ls2, (ts2, m2), ws2, is2)›]
obtain ts2' where red2: "r2.mthr.silent_moves (ls2, (ts2, m2), ws2, is2) (ls2, (ts2', m2), ws2, is2)"
and no_τ: "⋀t x1 x2 x2' m2'. ⟦ wset s1 t = None; thr s1 t = ⌊(x1, no_wait_locks)⌋; ts2' t = ⌊(x2, no_wait_locks)⌋;
⋀x' m'. r1.silent_move t (x1, shr s1) (x', m') ⟹ False ⟧
⟹ ¬ r2.silent_move t (x2, m2) (x2', m2')"
and mbisim: "s1 ≈m (ls2, (ts2', m2), ws2, is2)" by fastforce
from mbisim have mbisim_eqs: "ls2 = locks s1" "ws2 = wset s1" "is2 = interrupts s1"
by(simp_all add: mbisim_def)
let ?s2 = "(ls2, (ts2', m2), ws2, is2)"
from red2 have fin': "⋀t. r1.final_thread s1 t ⟹ r2.final_thread ?s2 t"
by(rule r2.τmRedT_preserves_final_thread)(rule fin)
from dead
have "t ∈ r2.deadlocked ?s2"
proof(coinduct)
case (deadlocked t)
thus ?case
proof(cases rule: r1.deadlocked_elims)
case (lock x1)
hence csmw: "⋀LT. r1.can_sync t x1 (shr s1) LT ⟹
∃lt∈LT. r1.must_wait s1 t lt (r1.deadlocked s1 ∪ r1.final_threads s1)"
by blast
from ‹thr s1 t = ⌊(x1, no_wait_locks)⌋› mbisim obtain x2
where "ts2' t = ⌊(x2, no_wait_locks)⌋" and bisim: "t ⊢ (x1, shr s1) ≈ (x2, m2)"
by(auto dest: mbisim_thrD1)
note ‹ts2' t = ⌊(x2, no_wait_locks)⌋› moreover
{ from ‹r1.must_sync t x1 (shr s1)› obtain ta1 x1' m1'
where r1: "t ⊢ (x1, shr s1) -1-ta1→ (x1', m1')"
and s1': "∃s1'. r1.actions_ok s1' t ta1" by(fastforce elim: r1.must_syncE)
have "¬ τmove1 (x1, shr s1) ta1 (x1', m1')" (is "¬ ?τ")
proof
assume "?τ"
hence "ta1 = ε" by(rule r1.silent_tl)
with r1 have "r1.can_sync t x1 (shr s1) {}"
by(auto intro!: r1.can_syncI simp add: collect_locks_def collect_interrupts_def)
from csmw[OF this] show False by blast
qed
from simulation1[OF bisim r1 this]
obtain x2' m2' x2'' m2'' ta2 where r2: "r2.silent_moves t (x2, m2) (x2', m2')"
and r2': "t ⊢ (x2', m2') -2-ta2→ (x2'', m2'')"
and τ2: "¬ τmove2 (x2', m2') ta2 (x2'', m2'')"
and bisim': "t ⊢ (x1', m1') ≈ (x2'', m2'')" and tasim: "ta1 ∼m ta2" by auto
from r2
have "∃ta2 x2' m2' s2'. t ⊢ (x2, m2) -2-ta2→ (x2', m2') ∧ r2.actions_ok s2' t ta2"
proof(cases rule: converse_rtranclpE2[consumes 1, case_names base step])
case base
from r2'[folded base] s1'[unfolded ex_actions_ok1_conv_ex_actions_ok2[OF tasim]]
show ?thesis by blast
next
case (step x2''' m2''')
hence "t ⊢ (x2, m2) -2-ε→ (x2''', m2''')" by(auto dest: r2.silent_tl)
moreover have "r2.actions_ok (undefined, (undefined, undefined), Map.empty, undefined) t ε" by auto
ultimately show ?thesis by-(rule exI conjI|assumption)+
qed
hence "r2.must_sync t x2 m2" unfolding r2.must_sync_def2 . }
moreover
{ fix LT
assume "r2.can_sync t x2 m2 LT"
then obtain ta2 x2' m2' where r2: "t ⊢ (x2, m2) -2-ta2→ (x2', m2')"
and LT: "LT = collect_locks ⦃ta2⦄⇘l⇙ <+> collect_cond_actions ⦃ta2⦄⇘c⇙ <+> collect_interrupts ⦃ta2⦄⇘i⇙"
by(auto elim: r2.can_syncE)
from ‹wset s1 t = None› ‹thr s1 t = ⌊(x1, no_wait_locks)⌋› ‹ts2' t = ⌊(x2, no_wait_locks)⌋›
have "¬ r2.silent_move t (x2, m2) (x2', m2')"
proof(rule no_τ)
fix x1' m1'
assume "r1.silent_move t (x1, shr s1) (x1', m1')"
hence "t ⊢ (x1, shr s1) -1-ε→ (x1', m1')" by(auto dest: r1.silent_tl)
hence "r1.can_sync t x1 (shr s1) {}"
by(auto intro: r1.can_syncI simp add: collect_locks_def collect_interrupts_def)
with csmw[OF this] show False by blast
qed
with r2 have "¬ τmove2 (x2, m2) ta2 (x2', m2')" by auto
from simulation2[OF bisim r2 this] obtain x1' m1' x1'' m1'' ta1
where τr1: "r1.silent_moves t (x1, shr s1) (x1', m1')"
and r1: "t ⊢ (x1', m1') -1-ta1→ (x1'', m1'')"
and nτ1: "¬ τmove1 (x1', m1') ta1 (x1'', m1'')"
and bisim': "t ⊢ (x1'', m1'') ≈ (x2', m2')"
and tlsim: "ta1 ∼m ta2" by auto
from τr1 obtain [simp]: "x1' = x1" "m1' = shr s1"
proof(cases rule: converse_rtranclpE2[consumes 1, case_names refl step])
case (step X M)
from ‹r1.silent_move t (x1, shr s1) (X, M)›
have "t ⊢ (x1, shr s1) -1-ε→ (X, M)" by(auto dest: r1.silent_tl)
hence "r1.can_sync t x1 (shr s1) {}"
by(auto intro: r1.can_syncI simp add: collect_locks_def collect_interrupts_def)
with csmw[OF this] have False by blast
thus ?thesis ..
qed blast
from tlsim LT have "LT = collect_locks ⦃ta1⦄⇘l⇙ <+> collect_cond_actions ⦃ta1⦄⇘c⇙ <+> collect_interrupts ⦃ta1⦄⇘i⇙"
by(auto simp add: ta_bisim_def)
with r1 have "r1.can_sync t x1 (shr s1) LT" by(auto intro: r1.can_syncI)
from csmw[OF this] obtain lt
where lt: "lt ∈ LT" and mw: "r1.must_wait s1 t lt (r1.deadlocked s1 ∪ r1.final_threads s1)" by blast
have subset: "r1.deadlocked s1 ∪ r1.final_threads s1 ⊆ r1.deadlocked s1 ∪ r2.deadlocked s2 ∪ r2.final_threads ?s2"
by(auto dest: fin')
from mw have "r2.must_wait ?s2 t lt (r1.deadlocked s1 ∪ r2.deadlocked ?s2 ∪ r2.final_threads ?s2)"
proof(cases rule: r1.must_wait_elims)
case lock thus ?thesis by(auto simp add: mbisim_eqs dest!: fin')
next
case (join t')
from ‹r1.not_final_thread s1 t'› obtain x1 ln
where "thr s1 t' = ⌊(x1, ln)⌋" by cases auto
with mbisim obtain x2 where "ts2' t' = ⌊(x2, ln)⌋" "t' ⊢ (x1, shr s1) ≈ (x2, m2)" by(auto dest: mbisim_thrD1)
show ?thesis
proof(cases "wset s1 t' = None ∧ ln = no_wait_locks")
case False
with ‹r1.not_final_thread s1 t'› ‹thr s1 t' = ⌊(x1, ln)⌋› ‹ts2' t' = ⌊(x2, ln)⌋› ‹lt = Inr (Inl t')› join
show ?thesis by(auto simp add: mbisim_eqs r2.not_final_thread_iff r1.final_thread_def)
next
case True
with ‹r1.not_final_thread s1 t'› ‹thr s1 t' = ⌊(x1, ln)⌋› have "¬ final1 x1" by(cases) auto
with join ‹thr s1 t' = ⌊(x1, ln)⌋› have "t' ∈ r1.deadlocked s1" by(auto simp add: r1.final_thread_def)
have "¬ final2 x2"
proof
assume "final2 x2"
with final2_simulation[OF ‹t' ⊢ (x1, shr s1) ≈ (x2, m2)›]
obtain x1' m1' where "r1.silent_moves t' (x1, shr s1) (x1', m1')"
and "t' ⊢ (x1', m1') ≈ (x2, m2)" "final1 x1'" by auto
from ‹r1.silent_moves t' (x1, shr s1) (x1', m1')› have "x1' = x1"
proof(cases rule: converse_rtranclpE2[consumes 1, case_names refl step])
case (step x1'' m1'')
from ‹r1.silent_move t' (x1, shr s1) (x1'', m1'')›
have "t' ⊢ (x1, shr s1) -1-ε→ (x1'', m1'')" by(auto dest: r1.silent_tl)
hence "r1.redT s1 (t', ε) (redT_upd_ε s1 t' x1'' m1'')"
using ‹thr s1 t' = ⌊(x1, ln)⌋› True
by -(erule r1.redT_normal, auto simp add: redT_updLns_def redT_updWs_def finfun_Diag_const2 o_def)
hence False using ‹t' ∈ r1.deadlocked s1› by(rule r1.red_no_deadlock)
thus ?thesis ..
qed simp
with ‹¬ final1 x1› ‹final1 x1'› show False by simp
qed
thus ?thesis using ‹ts2' t' = ⌊(x2, ln)⌋› join
by(auto simp add: r2.not_final_thread_iff r1.final_thread_def)
qed
next
case (interrupt t')
have "r2.all_final_except ?s2 (r1.deadlocked s1 ∪ r2.deadlocked ?s2 ∪ r2.final_threads ?s2)"
proof(rule r2.all_final_exceptI)
fix t''
assume "r2.not_final_thread ?s2 t''"
then obtain x2 ln where "thr ?s2 t'' = ⌊(x2, ln)⌋"
and fin: "¬ final2 x2 ∨ ln ≠ no_wait_locks ∨ wset ?s2 t'' ≠ None"
by(auto simp add: r2.not_final_thread_iff)
from ‹thr ?s2 t'' = ⌊(x2, ln)⌋› mbisim
obtain x1 where ts1t'': "thr s1 t'' = ⌊(x1, ln)⌋"
and bisim'': "t'' ⊢ (x1, shr s1) ≈ (x2, shr ?s2)"
by(auto dest: mbisim_thrD2)
have "r1.not_final_thread s1 t''"
proof(cases "wset ?s2 t'' = None ∧ ln = no_wait_locks")
case True
with fin have "¬ final2 x2" by simp
hence "¬ final1 x1"
proof(rule contrapos_nn)
assume "final1 x1"
with final1_simulation[OF bisim'']
obtain x2' m2' where τs2: "r2.silent_moves t'' (x2, shr ?s2) (x2', m2')"
and bisim''': "t'' ⊢ (x1, shr s1) ≈ (x2', m2')"
and "final2 x2'" by auto
from τs2 have "x2' = x2"
proof(cases rule: converse_rtranclpE2[consumes 1, case_names refl step])
case refl thus ?thesis by simp
next
case (step x2'' m2'')
from True have "wset s1 t'' = None" "thr s1 t'' = ⌊(x1, no_wait_locks)⌋" "ts2' t'' = ⌊(x2, no_wait_locks)⌋"
using ts1t'' ‹thr ?s2 t'' = ⌊(x2, ln)⌋› mbisim by(simp_all add: mbisim_def)
hence no_τ2: "¬ r2.silent_move t'' (x2, m2) (x2'', m2'')"
proof(rule no_τ)
fix x1' m1'
assume "r1.silent_move t'' (x1, shr s1) (x1', m1')"
with ‹final1 x1› show False by(auto dest: r1.final_no_red)
qed
with ‹r2.silent_move t'' (x2, shr ?s2) (x2'', m2'')› have False by simp
thus ?thesis ..
qed
with ‹final2 x2'› show "final2 x2" by simp
qed
with ts1t'' show ?thesis ..
next
case False
with ts1t'' mbisim show ?thesis by(auto simp add: r1.not_final_thread_iff mbisim_def)
qed
with ‹r1.all_final_except s1 (r1.deadlocked s1 ∪ r1.final_threads s1)›
have "t'' ∈ r1.deadlocked s1 ∪ r1.final_threads s1" by(rule r1.all_final_exceptD)
thus "t'' ∈ r1.deadlocked s1 ∪ r2.deadlocked ?s2 ∪ r2.final_threads ?s2"
by(auto dest: fin' simp add: mbisim_eqs)
qed
thus ?thesis using interrupt mbisim by(auto simp add: mbisim_def)
qed
hence "∃lt∈LT. r2.must_wait ?s2 t lt (r1.deadlocked s1 ∪ r2.deadlocked ?s2 ∪ r2.final_threads ?s2)"
using ‹lt ∈ LT› by blast }
moreover from mbisim ‹wset s1 t = None› have "wset ?s2 t = None" by(simp add: mbisim_def)
ultimately have ?Lock by simp
thus ?thesis ..
next
case (wait x1 ln)
from mbisim ‹thr s1 t = ⌊(x1, ln)⌋›
obtain x2 where "ts2' t = ⌊(x2, ln)⌋" by(auto dest: mbisim_thrD1)
moreover
have "r2.all_final_except ?s2 (r1.deadlocked s1)"
proof(rule r2.all_final_exceptI)
fix t
assume "r2.not_final_thread ?s2 t"
then obtain x2 ln where "ts2' t = ⌊(x2, ln)⌋" by(auto simp add: r2.not_final_thread_iff)
with mbisim obtain x1 where "thr s1 t = ⌊(x1, ln)⌋" "t ⊢ (x1, shr s1) ≈ (x2, m2)" by(auto dest: mbisim_thrD2)
hence "r1.not_final_thread s1 t" using ‹r2.not_final_thread ?s2 t› ‹ts2' t = ⌊(x2, ln)⌋› mbisim fin'[of t]
by(cases "wset s1 t")(auto simp add: r1.not_final_thread_iff r2.not_final_thread_iff mbisim_def r1.final_thread_def r2.final_thread_def)
with ‹r1.all_final_except s1 (r1.deadlocked s1)›
show "t ∈ r1.deadlocked s1" by(rule r1.all_final_exceptD)
qed
hence "r2.all_final_except ?s2 (r1.deadlocked s1 ∪ r2.deadlocked ?s2)"
by(rule r2.all_final_except_mono') blast
moreover
from ‹waiting (wset s1 t)› mbisim
have "waiting (wset ?s2 t)" by(simp add: mbisim_def)
ultimately have ?Wait by simp
thus ?thesis by blast
next
case (acquire x1 ln l t')
from mbisim ‹thr s1 t = ⌊(x1, ln)⌋›
obtain x2 where "ts2' t = ⌊(x2, ln)⌋" by(auto dest: mbisim_thrD1)
moreover
from ‹t' ∈ r1.deadlocked s1 ∨ r1.final_thread s1 t'›
have "(t' ∈ r1.deadlocked s1 ∨ t' ∈ r2.deadlocked ?s2) ∨ r2.final_thread ?s2 t'" by(blast dest: fin')
moreover
from mbisim ‹has_lock (locks s1 $ l) t'›
have "has_lock (locks ?s2 $ l) t'" by(simp add: mbisim_def)
ultimately have ?Acquire
using ‹0 < ln $ l› ‹t ≠ t'› ‹¬ waiting (wset s1 t)› mbisim
by(auto simp add: mbisim_def)
thus ?thesis by blast
qed
qed
with red1 red2 mbisim show ?thesis by(blast intro: rtranclp_trans)
qed
lemma deadlocked2_imp_τs_deadlocked1:
"⟦ s1 ≈m s2; t ∈ r2.deadlocked s2 ⟧
⟹ ∃s1'. r1.mthr.silent_moves s1 s1' ∧ t ∈ r1.deadlocked s1' ∧ s1' ≈m s2"
using FWdelay_bisimulation_diverge.deadlocked1_imp_τs_deadlocked2[OF FWdelay_bisimulation_diverge_flip]
unfolding flip_simps .
lemma deadlock1_imp_τs_deadlock2:
assumes mbisim: "s1 ≈m s2"
and dead: "r1.deadlock s1"
shows "∃s2'. r2.mthr.silent_moves s2 s2' ∧ r2.deadlock s2' ∧ s1 ≈m s2'"
proof(cases "∃t. r1.not_final_thread s1 t")
case True
then obtain t where nfin: "r1.not_final_thread s1 t" ..
from mfinal1_inv_simulation[OF mbisim]
obtain ls2 ts2 m2 ws2 is2 where red1: "r2.mthr.silent_moves s2 (ls2, (ts2, m2), ws2, is2)"
and "s1 ≈m (ls2, (ts2, m2), ws2, is2)" and "m2 = shr s2"
and fin: "⋀t. r1.final_thread s1 t ⟹ r2.final_thread (ls2, (ts2, m2), ws2, is2) t" by fastforce
from no_τMove1_τs_to_no_τMove2[OF ‹s1 ≈m (ls2, (ts2, m2), ws2, is2)›]
obtain ts2' where red2: "r2.mthr.silent_moves (ls2, (ts2, m2), ws2, is2) (ls2, (ts2', m2), ws2, is2)"
and no_τ: "⋀t x1 x2 x2' m2'. ⟦ wset s1 t = None; thr s1 t = ⌊(x1, no_wait_locks)⌋; ts2' t = ⌊(x2, no_wait_locks)⌋;
⋀x' m'. r1.silent_move t (x1, shr s1) (x', m') ⟹ False ⟧
⟹ ¬ r2.silent_move t (x2, m2) (x2', m2')"
and mbisim: "s1 ≈m (ls2, (ts2', m2), ws2, is2)" by fastforce
from mbisim have mbisim_eqs: "ls2 = locks s1" "ws2 = wset s1" "is2 = interrupts s1"
by(simp_all add: mbisim_def)
let ?s2 = "(ls2, (ts2', m2), ws2, is2)"
from red2 have fin': "⋀t. r1.final_thread s1 t ⟹ r2.final_thread ?s2 t"
by(rule r2.τmRedT_preserves_final_thread)(rule fin)
have "r2.deadlock ?s2"
proof(rule r2.deadlockI, goal_cases)
case (1 t x2)
note ts2t = ‹thr ?s2 t = ⌊(x2, no_wait_locks)⌋›
with mbisim obtain x1 where ts1t: "thr s1 t = ⌊(x1, no_wait_locks)⌋"
and bisim: "t ⊢ (x1, shr s1) ≈ (x2, m2)" by(auto dest: mbisim_thrD2)
from ‹wset ?s2 t = None› mbisim have ws1t: "wset s1 t = None" by(simp add: mbisim_def)
have "¬ final1 x1"
proof
assume "final1 x1"
with ts1t ws1t have "r1.final_thread s1 t" by(simp add: r1.final_thread_def)
hence "r2.final_thread ?s2 t" by(rule fin')
with ‹¬ final2 x2› ts2t ‹wset ?s2 t = None› show False by(simp add: r2.final_thread_def)
qed
from r1.deadlockD1[OF dead ts1t this ‹wset s1 t = None›]
have ms: "r1.must_sync t x1 (shr s1)"
and csmw: "⋀LT. r1.can_sync t x1 (shr s1) LT ⟹ ∃lt∈LT. r1.must_wait s1 t lt (dom (thr s1))"
by blast+
{
from ‹r1.must_sync t x1 (shr s1)› obtain ta1 x1' m1'
where r1: "t ⊢ (x1, shr s1) -1-ta1→ (x1', m1')"
and s1': "∃s1'. r1.actions_ok s1' t ta1" by(fastforce elim: r1.must_syncE)
have "¬ τmove1 (x1, shr s1) ta1 (x1', m1')" (is "¬ ?τ")
proof
assume "?τ"
hence "ta1 = ε" by(rule r1.silent_tl)
with r1 have "r1.can_sync t x1 (shr s1) {}"
by(auto intro!: r1.can_syncI simp add: collect_locks_def collect_interrupts_def)
from csmw[OF this] show False by blast
qed
from simulation1[OF bisim r1 this]
obtain x2' m2' x2'' m2'' ta2 where r2: "r2.silent_moves t (x2, m2) (x2', m2')"
and r2': "t ⊢ (x2', m2') -2-ta2→ (x2'', m2'')"
and bisim': "t ⊢ (x1', m1') ≈ (x2'', m2'')" and tasim: "ta1 ∼m ta2" by auto
from r2
have "∃ta2 x2' m2' s2'. t ⊢ (x2, m2) -2-ta2→ (x2', m2') ∧ r2.actions_ok s2' t ta2"
proof(cases rule: converse_rtranclpE2[consumes 1, case_names base step])
case base
from r2'[folded base] s1'[unfolded ex_actions_ok1_conv_ex_actions_ok2[OF tasim]]
show ?thesis by blast
next
case (step x2''' m2''')
hence "t ⊢ (x2, m2) -2-ε→ (x2''', m2''')" by(auto dest: r2.silent_tl)
moreover have "r2.actions_ok (undefined, (undefined, undefined), Map.empty, undefined) t ε" by auto
ultimately show ?thesis by-(rule exI conjI|assumption)+
qed
hence "r2.must_sync t x2 m2" unfolding r2.must_sync_def2 . }
moreover
{ fix LT
assume "r2.can_sync t x2 m2 LT"
then obtain ta2 x2' m2' where r2: "t ⊢ (x2, m2) -2-ta2→ (x2', m2')"
and LT: "LT = collect_locks ⦃ta2⦄⇘l⇙ <+> collect_cond_actions ⦃ta2⦄⇘c⇙ <+> collect_interrupts ⦃ta2⦄⇘i⇙"
by(auto elim: r2.can_syncE)
from ts2t have "ts2' t = ⌊(x2, no_wait_locks)⌋" by simp
with ws1t ts1t have "¬ r2.silent_move t (x2, m2) (x2', m2')"
proof(rule no_τ)
fix x1' m1'
assume "r1.silent_move t (x1, shr s1) (x1', m1')"
hence "t ⊢ (x1, shr s1) -1-ε→ (x1', m1')" by(auto dest: r1.silent_tl)
hence "r1.can_sync t x1 (shr s1) {}"
by(auto intro: r1.can_syncI simp add: collect_locks_def collect_interrupts_def)
with csmw[OF this] show False by blast
qed
with r2 have "¬ τmove2 (x2, m2) ta2 (x2', m2')" by auto
from simulation2[OF bisim r2 this] obtain x1' m1' x1'' m1'' ta1
where τr1: "r1.silent_moves t (x1, shr s1) (x1', m1')"
and r1: "t ⊢ (x1', m1') -1-ta1→ (x1'', m1'')"
and nτ1: "¬ τmove1 (x1', m1') ta1 (x1'', m1'')"
and bisim': "t ⊢ (x1'', m1'') ≈ (x2', m2')"
and tlsim: "ta1 ∼m ta2" by auto
from τr1 obtain [simp]: "x1' = x1" "m1' = shr s1"
proof(cases rule: converse_rtranclpE2[consumes 1, case_names refl step])
case (step X M)
from ‹r1.silent_move t (x1, shr s1) (X, M)›
have "t ⊢ (x1, shr s1) -1-ε→ (X, M)" by(auto dest: r1.silent_tl)
hence "r1.can_sync t x1 (shr s1) {}"
by(auto intro: r1.can_syncI simp add: collect_locks_def collect_interrupts_def)
with csmw[OF this] have False by blast
thus ?thesis ..
qed blast
from tlsim LT have "LT = collect_locks ⦃ta1⦄⇘l⇙ <+> collect_cond_actions ⦃ta1⦄⇘c⇙ <+> collect_interrupts ⦃ta1⦄⇘i⇙"
by(auto simp add: ta_bisim_def)
with r1 have "r1.can_sync t x1 (shr s1) LT" by(auto intro: r1.can_syncI)
from csmw[OF this] obtain lt
where lt: "lt ∈ LT" "r1.must_wait s1 t lt (dom (thr s1))" by blast
from ‹r1.must_wait s1 t lt (dom (thr s1))› have "r2.must_wait ?s2 t lt (dom (thr ?s2))"
proof(cases rule: r1.must_wait_elims)
case (lock l)
with mbisim_dom_eq[OF mbisim] show ?thesis by(auto simp add: mbisim_eqs)
next
case (join t')
from dead deadlock_mbisim_not_final_thread_pres[OF _ ‹r1.not_final_thread s1 t'› fin' mbisim]
have "r2.not_final_thread ?s2 t'" by auto
thus ?thesis using join mbisim_dom_eq[OF mbisim] by auto
next
case (interrupt t')
have "r2.all_final_except ?s2 (dom (thr ?s2))" by(auto intro!: r2.all_final_exceptI)
with interrupt show ?thesis by(auto simp add: mbisim_eqs)
qed
with lt have "∃lt∈LT. r2.must_wait ?s2 t lt (dom (thr ?s2))" by blast }
ultimately show ?case by fastforce
next
case (2 t x2 ln l)
note dead moreover
from mbisim ‹thr ?s2 t = ⌊(x2, ln)⌋›
obtain x1 where "thr s1 t = ⌊(x1, ln)⌋" by(auto dest: mbisim_thrD2)
moreover note ‹0 < ln $ l›
moreover from ‹¬ waiting (wset ?s2 t)› mbisim
have "¬ waiting (wset s1 t)" by(simp add: mbisim_def)
ultimately obtain l' t' where "0 < ln $ l'" "t ≠ t'" "thr s1 t' ≠ None" "has_lock (locks s1 $ l') t'"
by(rule r1.deadlockD2)
thus ?case using mbisim_thrNone_eq[OF mbisim, of t'] mbisim by(auto simp add: mbisim_def)
next
case (3 t x2 w)
from mbisim_thrD2[OF mbisim this]
obtain x1 where "thr s1 t = ⌊(x1, no_wait_locks)⌋" by auto
with dead have "wset s1 t ≠ ⌊PostWS w⌋" by(rule r1.deadlockD3[rule_format])
with mbisim show ?case by(simp add: mbisim_def)
qed
with red1 red2 mbisim show ?thesis by(blast intro: rtranclp_trans)
next
case False
hence "r1.mfinal s1" by(auto intro: r1.mfinalI simp add: r1.not_final_thread_iff)
from mfinal1_simulation[OF mbisim this]
obtain s2' where "τmRed2 s2 s2'" "s1 ≈m s2'" "r2.mfinal s2'" "shr s2' = shr s2" by blast
thus ?thesis by(blast intro: r2.mfinal_deadlock)
qed
lemma deadlock2_imp_τs_deadlock1:
"⟦ s1 ≈m s2; r2.deadlock s2 ⟧
⟹ ∃s1'. r1.mthr.silent_moves s1 s1' ∧ r1.deadlock s1' ∧ s1' ≈m s2"
using FWdelay_bisimulation_diverge.deadlock1_imp_τs_deadlock2[OF FWdelay_bisimulation_diverge_flip]
unfolding flip_simps .
lemma deadlocked'1_imp_τs_deadlocked'2:
"⟦ s1 ≈m s2; r1.deadlocked' s1 ⟧
⟹ ∃s2'. r2.mthr.silent_moves s2 s2' ∧ r2.deadlocked' s2' ∧ s1 ≈m s2'"
unfolding r1.deadlock_eq_deadlocked'[symmetric] r2.deadlock_eq_deadlocked'[symmetric]
by(rule deadlock1_imp_τs_deadlock2)
lemma deadlocked'2_imp_τs_deadlocked'1:
"⟦ s1 ≈m s2; r2.deadlocked' s2 ⟧ ⟹ ∃s1'. r1.mthr.silent_moves s1 s1' ∧ r1.deadlocked' s1' ∧ s1' ≈m s2"
unfolding r1.deadlock_eq_deadlocked'[symmetric] r2.deadlock_eq_deadlocked'[symmetric]
by(rule deadlock2_imp_τs_deadlock1)
end
context FWbisimulation begin
lemma mbisim_final_thread_preserve1:
assumes mbisim: "s1 ≈m s2" and fin: "r1.final_thread s1 t"
shows "r2.final_thread s2 t"
proof -
from fin obtain x1 where ts1t: "thr s1 t = ⌊(x1, no_wait_locks)⌋"
and fin1: "final1 x1" and ws1t: "wset s1 t = None"
by(auto elim: r1.final_threadE)
from mbisim ts1t obtain x2
where ts2t: "thr s2 t = ⌊(x2, no_wait_locks)⌋"
and bisim: "t ⊢ (x1, shr s1) ≈ (x2, shr s2)" by(auto dest: mbisim_thrD1)
note ts2t moreover from fin1 bisim have "final2 x2" by(auto dest: bisim_final)
moreover from mbisim ws1t have "wset s2 t = None" by(simp add: mbisim_def)
ultimately show ?thesis by(rule r2.final_threadI)
qed
lemma mbisim_final_thread_preserve2:
"⟦ s1 ≈m s2; r2.final_thread s2 t ⟧ ⟹ r1.final_thread s1 t"
using FWbisimulation.mbisim_final_thread_preserve1[OF FWbisimulation_flip]
unfolding flip_simps .
lemma mbisim_final_thread_inv:
"s1 ≈m s2 ⟹ r1.final_thread s1 t ⟷ r2.final_thread s2 t"
by(blast intro: mbisim_final_thread_preserve1 mbisim_final_thread_preserve2)
lemma mbisim_not_final_thread_inv:
assumes bisim: "mbisim s1 s2"
shows "r1.not_final_thread s1 = r2.not_final_thread s2"
proof(rule ext)
fix t
show "r1.not_final_thread s1 t = r2.not_final_thread s2 t"
proof(cases "thr s1 t")
case None
with mbisim_thrNone_eq[OF bisim, of t] have "thr s2 t = None" by simp
with None show ?thesis
by(auto elim!: r2.not_final_thread.cases r1.not_final_thread.cases
intro: r2.not_final_thread.intros r1.not_final_thread.intros)
next
case (Some a)
then obtain x1 ln where tst1: "thr s1 t = ⌊(x1, ln)⌋" by(cases a) auto
from mbisim_thrD1[OF bisim tst1] obtain x2
where tst2: "thr s2 t = ⌊(x2, ln)⌋" and bisimt: "t ⊢ (x1, shr s1) ≈ (x2, shr s2)" by blast
from bisim have "wset s2 = wset s1" by(simp add: mbisim_def)
with tst2 tst1 bisim_final[OF bisimt] show ?thesis
by(simp add: r1.not_final_thread_conv r2.not_final_thread_conv)(rule mbisim_final_thread_inv[OF bisim])
qed
qed
lemma mbisim_deadlocked_preserve1:
assumes mbisim: "s1 ≈m s2" and dead: "t ∈ r1.deadlocked s1"
shows "t ∈ r2.deadlocked s2"
proof -
from deadlocked1_imp_τs_deadlocked2[OF mbisim dead]
obtain s2' where "r2.mthr.silent_moves s2 s2'"
and "t ∈ r2.deadlocked s2'" by blast
from ‹r2.mthr.silent_moves s2 s2'› have "s2' = s2"
by(rule converse_rtranclpE)(auto elim: r2.mτmove.cases)
with ‹t ∈ r2.deadlocked s2'› show ?thesis by simp
qed
lemma mbisim_deadlocked_preserve2:
"⟦ s1 ≈m s2; t ∈ r2.deadlocked s2 ⟧ ⟹ t ∈ r1.deadlocked s1"
using FWbisimulation.mbisim_deadlocked_preserve1[OF FWbisimulation_flip]
unfolding flip_simps .
lemma mbisim_deadlocked_inv:
"s1 ≈m s2 ⟹ r1.deadlocked s1 = r2.deadlocked s2"
by(blast intro!: mbisim_deadlocked_preserve1 mbisim_deadlocked_preserve2)
lemma mbisim_deadlocked'_inv:
"s1 ≈m s2 ⟹ r1.deadlocked' s1 ⟷ r2.deadlocked' s2"
unfolding r1.deadlocked'_def r2.deadlocked'_def
by(simp add: mbisim_not_final_thread_inv mbisim_deadlocked_inv)
lemma mbisim_deadlock_inv:
"s1 ≈m s2 ⟹ r1.deadlock s1 = r2.deadlock s2"
unfolding r1.deadlock_eq_deadlocked' r2.deadlock_eq_deadlocked'
by(rule mbisim_deadlocked'_inv)
end
context FWbisimulation begin
lemma bisim_can_sync_preserve1:
assumes bisim: "t ⊢ (x1, m1) ≈ (x2, m2)" and cs: "t ⊢ ⟨x1, m1⟩ LT ≀1"
shows "t ⊢ ⟨x2, m2⟩ LT ≀2"
proof -
from cs obtain ta1 x1' m1' where red1: "t ⊢ (x1, m1) -1-ta1→ (x1', m1')"
and LT: "LT = collect_locks ⦃ta1⦄⇘l⇙ <+> collect_cond_actions ⦃ta1⦄⇘c⇙ <+> collect_interrupts ⦃ta1⦄⇘i⇙" by(rule r1.can_syncE)
from bisimulation.simulation1[OF bisimulation_axioms, OF bisim red1] obtain x2' ta2 m2'
where red2: "t ⊢ (x2, m2) -2-ta2→ (x2', m2')"
and tasim: "ta1 ∼m ta2" by fastforce
from tasim LT have "LT = collect_locks ⦃ta2⦄⇘l⇙ <+> collect_cond_actions ⦃ta2⦄⇘c⇙ <+> collect_interrupts ⦃ta2⦄⇘i⇙"
by(auto simp add: ta_bisim_def)
with red2 show ?thesis by(rule r2.can_syncI)
qed
lemma bisim_can_sync_preserve2:
"⟦ t ⊢ (x1, m1) ≈ (x2, m2); t ⊢ ⟨x2, m2⟩ LT ≀2 ⟧ ⟹ t ⊢ ⟨x1, m1⟩ LT ≀1"
using FWbisimulation.bisim_can_sync_preserve1[OF FWbisimulation_flip]
unfolding flip_simps .
lemma bisim_can_sync_inv:
"t ⊢ (x1, m1) ≈ (x2, m2) ⟹ t ⊢ ⟨x1, m1⟩ LT ≀1 ⟷ t ⊢ ⟨x2, m2⟩ LT ≀2"
by(blast intro: bisim_can_sync_preserve1 bisim_can_sync_preserve2)
lemma bisim_must_sync_preserve1:
assumes bisim: "t ⊢ (x1, m1) ≈ (x2, m2)" and ms: "t ⊢ ⟨x1, m1⟩ ≀1"
shows "t ⊢ ⟨x2, m2⟩ ≀2"
proof -
from ms obtain ta1 x1' m1' where red1: "t ⊢ (x1, m1) -1-ta1→ (x1', m1')"
and s1': "∃s1'. r1.actions_ok s1' t ta1" by(fastforce elim: r1.must_syncE)
from bisimulation.simulation1[OF bisimulation_axioms, OF bisim red1] obtain x2' ta2 m2'
where red2: "t ⊢ (x2, m2) -2-ta2→ (x2', m2')"
and tasim: "ta1 ∼m ta2" by fastforce
from ex_actions_ok1_conv_ex_actions_ok2[OF tasim, of t] s1' red2
show ?thesis unfolding r2.must_sync_def2 by blast
qed
lemma bisim_must_sync_preserve2:
"⟦ t ⊢ (x1, m1) ≈ (x2, m2); t ⊢ ⟨x2, m2⟩ ≀2 ⟧ ⟹ t ⊢ ⟨x1, m1⟩ ≀1"
using FWbisimulation.bisim_must_sync_preserve1[OF FWbisimulation_flip]
unfolding flip_simps .
lemma bisim_must_sync_inv:
"t ⊢ (x1, m1) ≈ (x2, m2) ⟹ t ⊢ ⟨x1, m1⟩ ≀1 ⟷ t ⊢ ⟨x2, m2⟩ ≀2"
by(blast intro: bisim_must_sync_preserve1 bisim_must_sync_preserve2)
end
end
Theory FWLiftingSem
section ‹Semantic properties of lifted predicates›
theory FWLiftingSem
imports
FWSemantics
FWLifting
begin
context multithreaded_base begin
lemma redT_preserves_ts_inv_ok:
"⟦ s -t▹ta→ s'; ts_inv_ok (thr s) I ⟧
⟹ ts_inv_ok (thr s') (upd_invs I P ⦃ta⦄⇘t⇙)"
by(erule redT.cases)(fastforce intro: ts_inv_ok_upd_invs ts_inv_ok_upd_ts redT_updTs_Some)+
lemma RedT_preserves_ts_inv_ok:
"⟦ s -▹ttas→* s'; ts_inv_ok (thr s) I ⟧
⟹ ts_inv_ok (thr s') (upd_invs I Q (concat (map (thr_a ∘ snd) ttas)))"
by(induct rule: RedT_induct)(auto intro: redT_preserves_ts_inv_ok)
lemma redT_upd_inv_ext:
fixes I :: "'t ⇀ 'i"
shows "⟦ s -t▹ta→ s'; ts_inv_ok (thr s) I ⟧ ⟹ I ⊆⇩m upd_invs I P ⦃ta⦄⇘t⇙"
by(erule redT.cases, auto intro: ts_inv_ok_inv_ext_upd_invs)
lemma RedT_upd_inv_ext:
fixes I :: "'t ⇀ 'i"
shows "⟦ s -▹ttas→* s'; ts_inv_ok (thr s) I ⟧
⟹ I ⊆⇩m upd_invs I P (concat (map (thr_a ∘ snd) ttas))"
proof(induct rule: RedT_induct)
case refl thus ?case by simp
next
case (step S TTAS S' T TA S'')
hence "ts_inv_ok (thr S') (upd_invs I P (concat (map (thr_a ∘ snd) TTAS)))"
by -(rule RedT_preserves_ts_inv_ok)
hence "upd_invs I P (concat (map (thr_a ∘ snd) TTAS)) ⊆⇩m upd_invs (upd_invs I P (concat (map (thr_a ∘ snd) TTAS))) P ⦃TA⦄⇘t⇙"
using step by -(rule redT_upd_inv_ext)
with step show ?case by(auto elim!: map_le_trans simp add: comp_def)
qed
end
locale lifting_inv = multithreaded final r convert_RA
for final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics" ("_ ⊢ _ -_→ _" [50,0,0,50] 80)
and convert_RA :: "'l released_locks ⇒ 'o list"
+
fixes P :: "'i ⇒ 't ⇒ 'x ⇒ 'm ⇒ bool"
assumes invariant_red: "⟦ t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩; P i t x m ⟧ ⟹ P i t x' m'"
and invariant_NewThread: "⟦ t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩; P i t x m; NewThread t'' x'' m' ∈ set ⦃ta⦄⇘t⇙ ⟧
⟹ ∃i''. P i'' t'' x'' m'"
and invariant_other: "⟦ t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩; P i t x m; P i'' t'' x'' m ⟧ ⟹ P i'' t'' x'' m'"
begin
lemma redT_updTs_invariant:
fixes ln
assumes tsiP: "ts_inv P I ts m"
and red: "t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩"
and tao: "thread_oks ts ⦃ta⦄⇘t⇙"
and tst: "ts t = ⌊(x, ln)⌋"
shows "ts_inv P (upd_invs I P ⦃ta⦄⇘t⇙) (redT_updTs ts ⦃ta⦄⇘t⇙(t ↦ (x', ln'))) m'"
proof(rule ts_invI)
fix T X LN
assume XLN: "(redT_updTs ts ⦃ta⦄⇘t⇙(t ↦ (x', ln'))) T = ⌊(X, LN)⌋"
from tsiP ‹ts t = ⌊(x, ln)⌋› obtain i where "I t = ⌊i⌋" "P i t x m"
by(auto dest: ts_invD)
show "∃i. upd_invs I P ⦃ta⦄⇘t⇙ T = ⌊i⌋ ∧ P i T X m'"
proof(cases "T = t")
case True
from red ‹P i t x m› have "P i t x' m'" by(rule invariant_red)
moreover from ‹I t = ⌊i⌋› ‹ts t = ⌊(x, ln)⌋› tao
have "upd_invs I P ⦃ta⦄⇘t⇙ t = ⌊i⌋"
by(simp add: upd_invs_Some)
ultimately show ?thesis using True XLN by simp
next
case False
show ?thesis
proof(cases "ts T")
case None
with XLN tao False have "∃m'. NewThread T X m' ∈ set ⦃ta⦄⇘t⇙"
by(auto dest: redT_updTs_new_thread)
with red have nt: "NewThread T X m' ∈ set ⦃ta⦄⇘t⇙" by(auto dest: new_thread_memory)
with red ‹P i t x m› have "∃i''. P i'' T X m'" by(rule invariant_NewThread)
hence "P (SOME i. P i T X m') T X m'" by(rule someI_ex)
with nt tao show ?thesis by(auto intro: SOME_new_thread_upd_invs)
next
case (Some a)
obtain X' LN' where [simp]: "a = (X', LN')" by(cases a)
with ‹ts T = ⌊a⌋› have esT: "ts T = ⌊(X', LN')⌋" by simp
hence "redT_updTs ts ⦃ta⦄⇘t⇙ T = ⌊(X', LN')⌋"
using ‹thread_oks ts ⦃ta⦄⇘t⇙› by(auto intro: redT_updTs_Some)
moreover from esT tsiP obtain i' where "I T = ⌊i'⌋" "P i' T X' m"
by(auto dest: ts_invD)
from red ‹P i t x m› ‹P i' T X' m›
have "P i' T X' m'" by(rule invariant_other)
moreover from ‹I T = ⌊i'⌋› esT tao have "upd_invs I P ⦃ta⦄⇘t⇙ T = ⌊i'⌋"
by(simp add: upd_invs_Some)
ultimately show ?thesis using XLN False by simp
qed
qed
qed
theorem redT_invariant:
assumes redT: "s -t▹ta→ s'"
and esinvP: "ts_inv P I (thr s) (shr s)"
shows "ts_inv P (upd_invs I P ⦃ta⦄⇘t⇙) (thr s') (shr s')"
using redT
proof(cases rule: redT_elims)
case acquire thus ?thesis using esinvP
by(auto intro!: ts_invI split: if_split_asm dest: ts_invD)
next
case (normal x x' m')
with esinvP
have "ts_inv P (upd_invs I P ⦃ta⦄⇘t⇙) (redT_updTs (thr s) ⦃ta⦄⇘t⇙(t ↦ (x', redT_updLns (locks s) t no_wait_locks ⦃ta⦄⇘l⇙))) m'"
by(auto intro: redT_updTs_invariant)
thus ?thesis using normal by simp
qed
theorem RedT_invariant:
assumes RedT: "s -▹ttas→* s'"
and esinvQ: "ts_inv P I (thr s) (shr s)"
shows "ts_inv P (upd_invs I P (concat (map (thr_a ∘ snd) ttas))) (thr s') (shr s')"
using RedT esinvQ
proof(induct rule: RedT_induct)
case refl thus ?case by(simp (no_asm))
next
case (step S TTAS S' T TA S'')
note IH = ‹ts_inv P I (thr S) (shr S) ⟹ ts_inv P (upd_invs I P (concat (map (thr_a ∘ snd) TTAS))) (thr S') (shr S')›
with ‹ts_inv P I (thr S) (shr S)›
have "ts_inv P (upd_invs I P (concat (map (thr_a ∘ snd) TTAS))) (thr S') (shr S')" by blast
with ‹S' -T▹TA→ S''›
have "ts_inv P (upd_invs (upd_invs I P (concat (map (thr_a ∘ snd) TTAS))) P ⦃TA⦄⇘t⇙) (thr S'') (shr S'')"
by(rule redT_invariant)
thus ?case by(simp add: comp_def)
qed
lemma invariant3p_ts_inv: "invariant3p redT {s. ∃I. ts_inv P I (thr s) (shr s)}"
by(auto intro!: invariant3pI dest: redT_invariant)
end
locale lifting_wf = multithreaded final r convert_RA
for final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics" ("_ ⊢ _ -_→ _" [50,0,0,50] 80)
and convert_RA :: "'l released_locks ⇒ 'o list"
+
fixes P :: "'t ⇒ 'x ⇒ 'm ⇒ bool"
assumes preserves_red: "⟦ t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩; P t x m ⟧ ⟹ P t x' m'"
and preserves_NewThread: "⟦ t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩; P t x m; NewThread t'' x'' m' ∈ set ⦃ta⦄⇘t⇙ ⟧
⟹ P t'' x'' m'"
and preserves_other: "⟦ t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩; P t x m; P t'' x'' m ⟧ ⟹ P t'' x'' m'"
begin
lemma lifting_inv: "lifting_inv final r (λ_ :: unit. P)"
by(unfold_locales)(blast intro: preserves_red preserves_NewThread preserves_other)+
lemma redT_updTs_preserves:
fixes ln
assumes esokQ: "ts_ok P ts m"
and red: "t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩"
and "ts t = ⌊(x, ln)⌋"
and "thread_oks ts ⦃ta⦄⇘t⇙"
shows "ts_ok P (redT_updTs ts ⦃ta⦄⇘t⇙(t ↦ (x', ln'))) m'"
proof -
interpret lifting_inv final r convert_RA "λ_ :: unit. P" by(rule lifting_inv)
from esokQ obtain I :: "'t ⇀ unit" where "ts_inv (λ_. P) I ts m" by(rule ts_ok_into_ts_inv_const)
hence "ts_inv (λ_. P) (upd_invs I (λ_. P) ⦃ta⦄⇘t⇙) (redT_updTs ts ⦃ta⦄⇘t⇙(t ↦ (x', ln'))) m'"
using red ‹thread_oks ts ⦃ta⦄⇘t⇙› ‹ts t = ⌊(x, ln)⌋› by(rule redT_updTs_invariant)
thus ?thesis by(rule ts_inv_const_into_ts_ok)
qed
theorem redT_preserves:
assumes redT: "s -t▹ta→ s'"
and esokQ: "ts_ok P (thr s) (shr s)"
shows "ts_ok P (thr s') (shr s')"
proof -
interpret lifting_inv final r convert_RA "λ_ :: unit. P" by(rule lifting_inv)
from esokQ obtain I :: "'t ⇀ unit" where "ts_inv (λ_. P) I (thr s) (shr s)" by(rule ts_ok_into_ts_inv_const)
with redT have "ts_inv (λ_. P) (upd_invs I (λ_. P) ⦃ta⦄⇘t⇙) (thr s') (shr s')" by(rule redT_invariant)
thus ?thesis by(rule ts_inv_const_into_ts_ok)
qed
theorem RedT_preserves:
"⟦ s -▹ttas→* s'; ts_ok P (thr s) (shr s) ⟧ ⟹ ts_ok P (thr s') (shr s')"
by(erule (1) RedT_lift_preserveD)(fastforce elim: redT_preserves)
lemma invariant3p_ts_ok: "invariant3p redT {s. ts_ok P (thr s) (shr s)}"
by(auto intro!: invariant3pI intro: redT_preserves)
end
lemma lifting_wf_Const [intro!]:
assumes "multithreaded final r"
shows "lifting_wf final r (λt x m. k)"
proof -
interpret multithreaded final r using assms .
show ?thesis by unfold_locales blast+
qed
end
Theory FWInitFinLift
section ‹Synthetic first and last actions for each thread›
theory FWInitFinLift
imports
FWLTS
FWLiftingSem
begin
datatype status =
PreStart
| Running
| Finished
abbreviation convert_TA_initial :: "('l,'t,'x,'m,'w,'o) thread_action ⇒ ('l,'t,status × 'x,'m,'w,'o) thread_action"
where "convert_TA_initial == convert_extTA (Pair PreStart)"
lemma convert_obs_initial_convert_TA_initial:
"convert_obs_initial (convert_TA_initial ta) = convert_TA_initial (convert_obs_initial ta)"
by(simp add: convert_obs_initial_def)
lemma convert_TA_initial_inject [simp]:
"convert_TA_initial ta = convert_TA_initial ta' ⟷ ta = ta'"
by(cases ta)(cases ta', auto)
context final_thread begin
primrec init_fin_final :: "status × 'x ⇒ bool"
where "init_fin_final (status, x) ⟷ status = Finished ∧ final x"
end
context multithreaded_base begin
inductive init_fin :: "('l,'t,status × 'x,'m,'w,'o action) semantics" ("_ ⊢ _ -_→i _" [50,0,0,51] 51)
where
NormalAction:
"t ⊢ ⟨x, m⟩ -ta→ ⟨x', m'⟩
⟹ t ⊢ ((Running, x), m) -convert_TA_initial (convert_obs_initial ta)→i ((Running, x'), m')"
| InitialThreadAction:
"t ⊢ ((PreStart, x), m) -⦃InitialThreadAction⦄→i ((Running, x), m)"
| ThreadFinishAction:
"final x ⟹ t ⊢ ((Running, x), m) -⦃ThreadFinishAction⦄→i ((Finished, x), m)"
end
declare split_paired_Ex [simp del]
inductive_simps (in multithreaded_base) init_fin_simps [simp]:
"t ⊢ ((Finished, x), m) -ta→i xm'"
"t ⊢ ((PreStart, x), m) -ta→i xm'"
"t ⊢ ((Running, x), m) -ta→i xm'"
"t ⊢ xm -ta→i ((Finished, x'), m')"
"t ⊢ xm -ta→i ((Running, x'), m')"
"t ⊢ xm -ta→i ((PreStart, x'), m')"
declare split_paired_Ex [simp]
context multithreaded begin
lemma multithreaded_init_fin: "multithreaded init_fin_final init_fin"
by(unfold_locales)(fastforce simp add: init_fin.simps convert_obs_initial_def ta_upd_simps dest: new_thread_memory)+
end
locale if_multithreaded_base = multithreaded_base +
constrains final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics"
and convert_RA :: "'l released_locks ⇒ 'o list"
sublocale if_multithreaded_base < "if": multithreaded_base
"init_fin_final"
"init_fin"
"map NormalAction ∘ convert_RA"
.
locale if_multithreaded = if_multithreaded_base + multithreaded +
constrains final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics"
and convert_RA :: "'l released_locks ⇒ 'o list"
sublocale if_multithreaded < "if": multithreaded
"init_fin_final"
"init_fin"
"map NormalAction ∘ convert_RA"
by(rule multithreaded_init_fin)
context τmultithreaded begin
inductive init_fin_τmove :: "('l,'t,status × 'x,'m,'w,'o action) τmoves"
where
"τmove (x, m) ta (x', m')
⟹ init_fin_τmove ((Running, x), m) (convert_TA_initial (convert_obs_initial ta)) ((Running, x'), m')"
lemma init_fin_τmove_simps [simp]:
"init_fin_τmove ((PreStart, x), m) ta x'm' = False"
"init_fin_τmove xm ta ((PreStart, x'), m') = False"
"init_fin_τmove ((Running, x), m) ta ((s, x'), m') ⟷
(∃ta'. ta = convert_TA_initial (convert_obs_initial ta') ∧ s = Running ∧ τmove (x, m) ta' (x', m'))"
"init_fin_τmove ((s, x), m) ta ((Running, x'), m') ⟷
s = Running ∧ (∃ta'. ta = convert_TA_initial (convert_obs_initial ta') ∧ τmove (x, m) ta' (x', m'))"
"init_fin_τmove ((Finished, x), m) ta x'm' = False"
"init_fin_τmove xm ta ((Finished, x'), m') = False"
by(simp_all add: init_fin_τmove.simps)
lemma init_fin_silent_move_RunningI:
assumes "silent_move t (x, m) (x', m')"
shows "τtrsys.silent_move (init_fin t) init_fin_τmove ((Running, x), m) ((Running, x'), m')"
using assms by(cases)(auto intro: τtrsys.silent_move.intros init_fin.NormalAction)
lemma init_fin_silent_moves_RunningI:
assumes "silent_moves t (x, m) (x', m')"
shows "τtrsys.silent_moves (init_fin t) init_fin_τmove ((Running, x), m) ((Running, x'), m')"
using assms
by(induct rule: rtranclp_induct2)(auto elim: rtranclp.rtrancl_into_rtrancl intro: init_fin_silent_move_RunningI)
lemma init_fin_silent_moveD:
assumes "τtrsys.silent_move (init_fin t) init_fin_τmove ((s, x), m) ((s', x'), m')"
shows "silent_move t (x, m) (x', m') ∧ s = s' ∧ s' = Running"
using assms by(auto elim!: τtrsys.silent_move.cases init_fin.cases)
lemma init_fin_silent_movesD:
assumes "τtrsys.silent_moves (init_fin t) init_fin_τmove ((s, x), m) ((s', x'), m')"
shows "silent_moves t (x, m) (x', m') ∧ s = s'"
using assms
by(induct "((s, x), m)" "((s', x'), m')" arbitrary: s' x' m')
(auto 7 2 simp only: dest!: init_fin_silent_moveD intro: rtranclp.rtrancl_into_rtrancl)
lemma init_fin_τdivergeD:
assumes "τtrsys.τdiverge (init_fin t) init_fin_τmove ((status, x), m)"
shows "τdiverge t (x, m) ∧ status = Running"
proof
from assms show "status = Running"
by(cases rule: τtrsys.τdiverge.cases[consumes 1])(auto dest: init_fin_silent_moveD)
moreover define xm where "xm = (x, m)"
ultimately have "∃x m. xm = (x, m) ∧ τtrsys.τdiverge (init_fin t) init_fin_τmove ((Running, x), m)"
using assms by blast
thus "τdiverge t xm"
proof(coinduct)
case (τdiverge xm)
then obtain x m
where diverge: "τtrsys.τdiverge (init_fin t) init_fin_τmove ((Running, x), m)"
and xm: "xm = (x, m)" by blast
thus ?case
by(cases rule:τtrsys.τdiverge.cases[consumes 1])(auto dest!: init_fin_silent_moveD)
qed
qed
lemma init_fin_τdiverge_RunningI:
assumes "τdiverge t (x, m)"
shows "τtrsys.τdiverge (init_fin t) init_fin_τmove ((Running, x), m)"
proof -
define sxm where "sxm = ((Running, x), m)"
with assms have "∃x m. τdiverge t (x, m) ∧ sxm = ((Running, x), m)" by blast
thus "τtrsys.τdiverge (init_fin t) init_fin_τmove sxm"
proof(coinduct rule: τtrsys.τdiverge.coinduct[consumes 1, case_names τdiverge])
case (τdiverge sxm)
then obtain x m where "τdiverge t (x, m)" and "sxm = ((Running, x), m)" by blast
thus ?case by(cases)(auto intro: init_fin_silent_move_RunningI)
qed
qed
lemma init_fin_τdiverge_conv:
"τtrsys.τdiverge (init_fin t) init_fin_τmove ((status, x), m) ⟷
τdiverge t (x, m) ∧ status = Running"
by(blast intro: init_fin_τdiverge_RunningI dest: init_fin_τdivergeD)
end
lemma init_fin_τmoves_False:
"τmultithreaded.init_fin_τmove (λ_ _ _. False) = (λ_ _ _. False)"
by(simp add: fun_eq_iff τmultithreaded.init_fin_τmove.simps)
locale if_τmultithreaded = if_multithreaded_base + τmultithreaded +
constrains final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics"
and convert_RA :: "'l released_locks ⇒ 'o list"
and τmove :: "('l,'t,'x,'m,'w,'o) τmoves"
sublocale if_τmultithreaded < "if": τmultithreaded
"init_fin_final"
"init_fin"
"map NormalAction ∘ convert_RA"
"init_fin_τmove"
.
locale if_τmultithreaded_wf = if_multithreaded_base + τmultithreaded_wf +
constrains final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics"
and convert_RA :: "'l released_locks ⇒ 'o list"
and τmove :: "('l,'t,'x,'m,'w,'o) τmoves"
sublocale if_τmultithreaded_wf < if_multithreaded
by unfold_locales
sublocale if_τmultithreaded_wf < if_τmultithreaded .
context τmultithreaded_wf begin
lemma τmultithreaded_wf_init_fin:
"τmultithreaded_wf init_fin_final init_fin init_fin_τmove"
proof -
interpret "if": multithreaded init_fin_final init_fin "map NormalAction ∘ convert_RA"
by(rule multithreaded_init_fin)
show ?thesis
proof(unfold_locales)
fix t x m ta x' m'
assume "init_fin_τmove (x, m) ta (x', m')" "t ⊢ (x, m) -ta→i (x', m')"
thus "m = m'" by(cases)(auto dest: τmove_heap)
next
fix s ta s'
assume "init_fin_τmove s ta s'"
thus "ta = ε" by(cases)(auto dest: silent_tl)
qed
qed
end
sublocale if_τmultithreaded_wf < "if": τmultithreaded_wf
"init_fin_final"
"init_fin"
"map NormalAction ∘ convert_RA"
"init_fin_τmove"
by(rule τmultithreaded_wf_init_fin)
primrec init_fin_lift_inv :: "('i ⇒ 't ⇒ 'x ⇒ 'm ⇒ bool) ⇒ 'i ⇒ 't ⇒ status × 'x ⇒ 'm ⇒ bool"
where "init_fin_lift_inv P I t (s, x) = P I t x"
context lifting_inv begin
lemma lifting_inv_init_fin_lift_inv:
"lifting_inv init_fin_final init_fin (init_fin_lift_inv P)"
proof -
interpret "if": multithreaded init_fin_final init_fin "map NormalAction ∘ convert_RA"
by(rule multithreaded_init_fin)
show ?thesis
by(unfold_locales)(fastforce elim!: init_fin.cases dest: invariant_red invariant_NewThread invariant_other)+
qed
end
locale if_lifting_inv =
if_multithreaded +
lifting_inv +
constrains final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics"
and convert_RA :: "'l released_locks ⇒ 'o list"
and P :: "'i ⇒ 't ⇒ 'x ⇒ 'm ⇒ bool"
sublocale if_lifting_inv < "if": lifting_inv
init_fin_final
init_fin
"map NormalAction ∘ convert_RA"
"init_fin_lift_inv P"
by(rule lifting_inv_init_fin_lift_inv)
primrec init_fin_lift :: "('t ⇒ 'x ⇒ 'm ⇒ bool) ⇒ 't ⇒ status × 'x ⇒ 'm ⇒ bool"
where "init_fin_lift P t (s, x) = P t x"
context lifting_wf begin
lemma lifting_wf_init_fin_lift:
"lifting_wf init_fin_final init_fin (init_fin_lift P)"
proof -
interpret "if": multithreaded init_fin_final init_fin "map NormalAction ∘ convert_RA"
by(rule multithreaded_init_fin)
show ?thesis
by(unfold_locales)(fastforce elim!: init_fin.cases dest: dest: preserves_red preserves_other preserves_NewThread)+
qed
end
locale if_lifting_wf =
if_multithreaded +
lifting_wf +
constrains final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics"
and convert_RA :: "'l released_locks ⇒ 'o list"
and P :: "'t ⇒ 'x ⇒ 'm ⇒ bool"
sublocale if_lifting_wf < "if": lifting_wf
init_fin_final
init_fin
"map NormalAction ∘ convert_RA"
"init_fin_lift P"
by(rule lifting_wf_init_fin_lift)
lemma (in if_lifting_wf) if_lifting_inv:
"if_lifting_inv final r (λ_::unit. P)"
proof -
interpret lifting_inv final r convert_RA "λ_ :: unit. P" by(rule lifting_inv)
show ?thesis by unfold_locales
qed
locale τlifting_inv = τmultithreaded_wf +
lifting_inv +
constrains final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics"
and convert_RA :: "'l released_locks ⇒ 'o list"
and τmove :: "('l,'t,'x,'m,'w,'o) τmoves"
and P :: "'i ⇒ 't ⇒ 'x ⇒ 'm ⇒ bool"
begin
lemma redT_silent_move_invariant:
"⟦ τmredT s s'; ts_inv P Is (thr s) (shr s) ⟧ ⟹ ts_inv P Is (thr s') (shr s')"
by(auto dest!: redT_invariant mτmove_silentD)
lemma redT_silent_moves_invariant:
"⟦ mthr.silent_moves s s'; ts_inv P Is (thr s) (shr s) ⟧ ⟹ ts_inv P Is (thr s') (shr s')"
by(induct rule: rtranclp_induct)(auto dest: redT_silent_move_invariant)
lemma redT_τrtrancl3p_invariant:
"⟦ mthr.τrtrancl3p s ttas s'; ts_inv P Is (thr s) (shr s) ⟧
⟹ ts_inv P (upd_invs Is P (concat (map (thr_a ∘ snd) ttas))) (thr s') (shr s')"
proof(induct arbitrary: Is rule: mthr.τrtrancl3p.induct)
case τrtrancl3p_refl thus ?case by simp
next
case (τrtrancl3p_step s s' tls s'' tl)
thus ?case by(cases tl)(force dest: redT_invariant)
next
case (τrtrancl3p_τstep s s' tls s'' tl)
thus ?case by(cases tl)(force dest: redT_invariant mτmove_silentD)
qed
end
locale τlifting_wf = τmultithreaded +
lifting_wf +
constrains final :: "'x ⇒ bool"
and r :: "('l,'t,'x,'m,'w,'o) semantics"
and convert_RA :: "'l released_locks ⇒ 'o list"
and τmove :: "('l,'t,'x,'m,'w,'o) τmoves"
and P :: "'t ⇒ 'x ⇒ 'm ⇒ bool"
begin
lemma redT_silent_move_preserves:
"⟦ τmredT s s'; ts_ok P (thr s) (shr s) ⟧ ⟹ ts_ok P (thr s') (shr s')"
by(auto dest: redT_preserves)
lemma redT_silent_moves_preserves:
"⟦ mthr.silent_moves s s'; ts_ok P (thr s) (shr s) ⟧ ⟹ ts_ok P (thr s') (shr s')"
by(induct rule: rtranclp.induct)(auto dest: redT_silent_move_preserves)
lemma redT_τrtrancl3p_preserves:
"⟦ mthr.τrtrancl3p s ttas s'; ts_ok P (thr s) (shr s) ⟧ ⟹ ts_ok P (thr s') (shr s')"
by(induct rule: mthr.τrtrancl3p.induct)(auto dest: redT_silent_moves_preserves redT_preserves)
end
definition init_fin_lift_state :: "status ⇒ ('l,'t,'x,'m,'w) state ⇒ ('l,'t,status × 'x,'m,'w) state"
where "init_fin_lift_state s σ = (locks σ, (λt. map_option (λ(x, ln). ((s, x), ln)) (thr σ t), shr σ), wset σ, interrupts σ)"
definition init_fin_descend_thr :: "('l,'t,'status × 'x) thread_info ⇒ ('l,'t,'x) thread_info"
where "init_fin_descend_thr ts = map_option (λ((s, x), ln). (x, ln)) ∘ ts"
definition init_fin_descend_state :: "('l,'t,'status × 'x,'m,'w) state ⇒ ('l,'t,'x,'m,'w) state"
where "init_fin_descend_state σ = (locks σ, (init_fin_descend_thr (thr σ), shr σ), wset σ, interrupts σ)"
lemma ts_ok_init_fin_lift_init_fin_lift_state [simp]:
"ts_ok (init_fin_lift P) (thr (init_fin_lift_state s σ)) (shr (init_fin_lift_state s σ)) ⟷ ts_ok P (thr σ) (shr σ)"
by(auto simp add: init_fin_lift_state_def intro!: ts_okI dest: ts_okD)
lemma ts_inv_init_fin_lift_inv_init_fin_lift_state [simp]:
"ts_inv (init_fin_lift_inv P) I (thr (init_fin_lift_state s σ)) (shr (init_fin_lift_state s σ)) ⟷
ts_inv P I (thr σ) (shr σ)"
by(auto simp add: init_fin_lift_state_def intro!: ts_invI dest: ts_invD)
lemma init_fin_lift_state_conv_simps:
shows shr_init_fin_lift_state: "shr (init_fin_lift_state s σ) = shr σ"
and locks_init_fin_lift_state: "locks (init_fin_lift_state s σ) = locks σ"
and wset_init_fin_lift_state: "wset (init_fin_lift_state s σ) = wset σ"
and interrupts_init_fin_lift_stae: "interrupts (init_fin_lift_state s σ) = interrupts σ"
and thr_init_fin_list_state:
"thr (init_fin_lift_state s σ) t = map_option (λ(x, ln). ((s, x), ln)) (thr σ t)"
by(simp_all add: init_fin_lift_state_def)
lemma thr_init_fin_list_state':
"thr (init_fin_lift_state s σ) = map_option (λ(x, ln). ((s, x), ln)) ∘ thr σ"
by(simp add: fun_eq_iff thr_init_fin_list_state)
lemma init_fin_descend_thr_Some_conv [simp]:
"⋀ln. ts t = ⌊((status, x), ln)⌋ ⟹ init_fin_descend_thr ts t = ⌊(x, ln)⌋"
by(simp add: init_fin_descend_thr_def)
lemma init_fin_descend_thr_None_conv [simp]:
"ts t = None ⟹ init_fin_descend_thr ts t = None"
by(simp add: init_fin_descend_thr_def)
lemma init_fin_descend_thr_eq_None [simp]:
"init_fin_descend_thr ts t = None ⟷ ts t = None"
by(simp add: init_fin_descend_thr_def)
lemma init_fin_descend_state_simps [simp]:
"init_fin_descend_state (ls, (ts, m), ws, is) = (ls, (init_fin_descend_thr ts, m), ws, is)"
"locks (init_fin_descend_state s) = locks s"
"thr (init_fin_descend_state s) = init_fin_descend_thr (thr s)"
"shr (init_fin_descend_state s) = shr s"
"wset (init_fin_descend_state s) = wset s"
"interrupts (init_fin_descend_state s) = interrupts s"
by(simp_all add: init_fin_descend_state_def)
lemma init_fin_descend_thr_update [simp]:
"init_fin_descend_thr (ts(t := v)) = (init_fin_descend_thr ts)(t := map_option (λ((status, x), ln). (x, ln)) v)"
by(simp add: init_fin_descend_thr_def fun_eq_iff)
lemma ts_ok_init_fin_descend_state:
"ts_ok P (init_fin_descend_thr ts) = ts_ok (init_fin_lift P) ts"
by(rule ext)(auto 4 3 intro!: ts_okI dest: ts_okD simp add: init_fin_descend_thr_def)
lemma free_thread_id_init_fin_descend_thr [simp]:
"free_thread_id (init_fin_descend_thr ts) = free_thread_id ts"
by(simp add: free_thread_id.simps fun_eq_iff)
lemma redT_updT'_init_fin_descend_thr_eq_None [simp]:
"redT_updT' (init_fin_descend_thr ts) nt t = None ⟷ redT_updT' ts nt t = None"
by(cases nt) simp_all
lemma thread_ok_init_fin_descend_thr [simp]:
"thread_ok (init_fin_descend_thr ts) nta = thread_ok ts nta"
by(cases nta) simp_all
lemma threads_ok_init_fin_descend_thr [simp]:
"thread_oks (init_fin_descend_thr ts) ntas = thread_oks ts ntas"
by(induct ntas arbitrary: ts)(auto elim!: thread_oks_ts_change[THEN iffD1, rotated 1])
lemma init_fin_descend_thr_redT_updT [simp]:
"init_fin_descend_thr (redT_updT ts (convert_new_thread_action (Pair status) nt)) =
redT_updT (init_fin_descend_thr ts) nt"
by(cases nt) simp_all
lemma init_fin_descend_thr_redT_updTs [simp]:
"init_fin_descend_thr (redT_updTs ts (map (convert_new_thread_action (Pair status)) nts)) =
redT_updTs (init_fin_descend_thr ts) nts"
by(induct nts arbitrary: ts) simp_all
context final_thread begin
lemma cond_action_ok_init_fin_descend_stateI [simp]:
"final_thread.cond_action_ok init_fin_final s t ct ⟹ cond_action_ok (init_fin_descend_state s) t ct"
by(cases ct)(auto simp add: final_thread.cond_action_ok.simps init_fin_descend_thr_def)
lemma cond_action_oks_init_fin_descend_stateI [simp]:
"final_thread.cond_action_oks init_fin_final s t cts ⟹ cond_action_oks (init_fin_descend_state s) t cts"
by(induct cts)(simp_all add: final_thread.cond_action_oks.simps cond_action_ok_init_fin_descend_stateI)
end
definition lift_start_obs :: "'t ⇒ 'o list ⇒ ('t × 'o action) list"
where "lift_start_obs t obs = (t, InitialThreadAction) # map (λob. (t, NormalAction ob)) obs"
lemma length_lift_start_obs [simp]: "length (lift_start_obs t obs) = Suc (length obs)"
by(simp add: lift_start_obs_def)
lemma set_lift_start_obs [simp]:
"set (lift_start_obs t obs) =
insert (t, InitialThreadAction) ((Pair t ∘ NormalAction) ` set obs)"
by(auto simp add: lift_start_obs_def o_def)
lemma distinct_lift_start_obs [simp]: "distinct (lift_start_obs t obs) = distinct obs"
by(auto simp add: lift_start_obs_def distinct_map intro: inj_onI)
end
Theory FWBisimLift
theory FWBisimLift imports
FWInitFinLift
FWBisimulation
begin
context FWbisimulation_base begin
inductive init_fin_bisim :: "'t ⇒ ((status × 'x1) × 'm1, (status × 'x2) × 'm2) bisim"
("_ ⊢ _ ≈i _"[50,50,50] 60)
for t :: 't
where
PreStart: "t ⊢ (x1, m1) ≈ (x2, m2) ⟹ t ⊢ ((PreStart, x1), m1) ≈i ((PreStart, x2), m2)"
| Running: "t ⊢ (x1, m1) ≈ (x2, m2) ⟹ t ⊢ ((Running, x1), m1) ≈i ((Running, x2), m2)"
| Finished:
"⟦ t ⊢ (x1, m1) ≈ (x2, m2); final1 x1; final2 x2 ⟧
⟹ t ⊢ ((Finished, x1), m1) ≈i ((Finished, x2), m2)"
definition init_fin_bisim_wait :: "(status × 'x1, status × 'x2) bisim" ("_ ≈iw _" [50,50] 60)
where
"init_fin_bisim_wait = (λ(status1, x1) (status2, x2). status1 = Running ∧ status2 = Running ∧ x1 ≈w x2)"
inductive_simps init_fin_bisim_simps [simp]:
"t ⊢ ((PreStart, x1), m1) ≈i ((s2, x2), m2)"
"t ⊢ ((Running, x1), m1) ≈i ((s2, x2), m2)"
"t ⊢ ((Finished, x1), m1) ≈i ((s2, x2), m2)"
"t ⊢ ((s1, x1), m1) ≈i ((PreStart, x2), m2)"
"t ⊢ ((s1, x1), m1) ≈i ((Running, x2), m2)"
"t ⊢ ((s1, x1), m1) ≈i ((Finished, x2), m2)"
lemma init_fin_bisim_iff:
"t ⊢ ((s1, x1), m1) ≈i ((s2, x2), m2) ⟷
s1 = s2 ∧ t ⊢ (x1, m1) ≈ (x2, m2) ∧ (s2 = Finished ⟶ final1 x1 ∧ final2 x2)"
by(cases s1) auto
lemma nta_bisim_init_fin_bisim [simp]:
"nta_bisim init_fin_bisim (convert_new_thread_action (Pair PreStart) nt1)
(convert_new_thread_action (Pair PreStart) nt2) =
nta_bisim bisim nt1 nt2"
by(cases nt1) simp_all
lemma ta_bisim_init_fin_bisim_convert [simp]:
"ta_bisim init_fin_bisim (convert_TA_initial (convert_obs_initial ta1)) (convert_TA_initial (convert_obs_initial ta2)) ⟷ ta1 ∼m ta2"
by(auto simp add: ta_bisim_def list_all2_map1 list_all2_map2)
lemma ta_bisim_init_fin_bisim_InitialThreadAction [simp]:
"ta_bisim init_fin_bisim ⦃InitialThreadAction⦄ ⦃InitialThreadAction⦄"
by(simp add: ta_bisim_def)
lemma ta_bisim_init_fin_bisim_ThreadFinishAction [simp]:
"ta_bisim init_fin_bisim ⦃ThreadFinishAction⦄ ⦃ThreadFinishAction⦄"
by(simp add: ta_bisim_def)
lemma init_fin_bisim_wait_simps [simp]:
"(status1, x1) ≈iw (status2, x2) ⟷ status1 = Running ∧ status2 = Running ∧ x1 ≈w x2"
by(simp add: init_fin_bisim_wait_def)
lemma init_fin_lift_state_mbisimI:
"s ≈m s' ⟹
FWbisimulation_base.mbisim init_fin_bisim init_fin_bisim_wait (init_fin_lift_state Running s) (init_fin_lift_state Running s')"
apply(rule FWbisimulation_base.mbisimI)
apply(simp add: thr_init_fin_list_state' o_def dom_map_option mbisim_finite1)
apply(simp add: locks_init_fin_lift_state mbisim_def)
apply(simp add: wset_init_fin_lift_state mbisim_def)
apply(simp add: interrupts_init_fin_lift_stae mbisim_def)
apply(clarsimp simp add: wset_init_fin_lift_state mbisim_def thr_init_fin_list_state' o_def wset_thread_ok_conv_dom dom_map_option del: subsetI)
apply(drule_tac t=t in mbisim_thrNone_eq)
apply(simp add: thr_init_fin_list_state)
apply(clarsimp simp add: thr_init_fin_list_state shr_init_fin_lift_state wset_init_fin_lift_state init_fin_bisim_iff)
apply(frule (1) mbisim_thrD1)
apply(simp add: mbisim_def)
done
end
context FWdelay_bisimulation_base begin
lemma init_fin_delay_bisimulation_final_base:
"delay_bisimulation_final_base (r1.init_fin t) (r2.init_fin t) (init_fin_bisim t)
r1.init_fin_τmove r2.init_fin_τmove (λ(x1, m). r1.init_fin_final x1) (λ(x2, m). r2.init_fin_final x2)"
by(unfold_locales)(auto 4 3)
end
lemma init_fin_bisim_flip [flip_simps]:
"FWbisimulation_base.init_fin_bisim final2 final1 (λt. flip (bisim t)) =
(λt. flip (FWbisimulation_base.init_fin_bisim final1 final2 bisim t))"
by(auto simp only: FWbisimulation_base.init_fin_bisim_iff flip_simps fun_eq_iff split_paired_Ex)
lemma init_fin_bisim_wait_flip [flip_simps]:
"FWbisimulation_base.init_fin_bisim_wait (flip bisim_wait) =
flip (FWbisimulation_base.init_fin_bisim_wait bisim_wait)"
by(auto simp add: fun_eq_iff FWbisimulation_base.init_fin_bisim_wait_simps flip_simps)
context FWdelay_bisimulation_lift_aux begin
lemma init_fin_FWdelay_bisimulation_lift_aux:
"FWdelay_bisimulation_lift_aux r1.init_fin_final r1.init_fin r2.init_fin_final r2.init_fin r1.init_fin_τmove r2.init_fin_τmove"
by(intro FWdelay_bisimulation_lift_aux.intro r1.τmultithreaded_wf_init_fin r2.τmultithreaded_wf_init_fin)
lemma init_fin_FWdelay_bisimulation_final_base:
"FWdelay_bisimulation_final_base
r1.init_fin_final r1.init_fin r2.init_fin_final r2.init_fin
init_fin_bisim r1.init_fin_τmove r2.init_fin_τmove"
by(intro FWdelay_bisimulation_final_base.intro init_fin_FWdelay_bisimulation_lift_aux FWdelay_bisimulation_final_base_axioms.intro init_fin_delay_bisimulation_final_base)
end
context FWdelay_bisimulation_obs begin
lemma init_fin_simulation1:
assumes bisim: "t ⊢ s1 ≈i s2"
and red1: "r1.init_fin t s1 tl1 s1'"
and τ1: "¬ r1.init_fin_τmove s1 tl1 s1'"
shows "∃s2' s2'' tl2. (τtrsys.silent_move (r2.init_fin t) r2.init_fin_τmove)⇧*⇧* s2 s2' ∧
r2.init_fin t s2' tl2 s2'' ∧ ¬ r2.init_fin_τmove s2' tl2 s2'' ∧
t ⊢ s1' ≈i s2'' ∧ ta_bisim init_fin_bisim tl1 tl2"
proof -
from bisim obtain status x1 m1 x2 m2
where s1: "s1 = ((status, x1), m1)"
and s2: "s2 = ((status, x2), m2)"
and bisim: "t ⊢ (x1, m1) ≈ (x2, m2)"
and finished: "status = Finished ⟹ final1 x1 ∧ final2 x2"
by(cases s1)(cases s2, fastforce simp add: init_fin_bisim_iff)
from red1 show ?thesis unfolding s1
proof(cases)
case (NormalAction ta1 x1' m1')
with τ1 s1 have "¬ τmove1 (x1, m1) ta1 (x1', m1')" by(simp)
from simulation1[OF bisim ‹t ⊢ (x1, m1) -1-ta1→ (x1', m1')› this]
obtain x2' m2' x2'' m2'' ta2
where red2: "r2.silent_moves t (x2, m2) (x2', m2')"
and red2': "t ⊢ (x2', m2') -2-ta2→ (x2'', m2'')"
and τ2: "¬ τmove2 (x2', m2') ta2 (x2'', m2'')"
and bisim': "t ⊢ (x1', m1') ≈ (x2'', m2'')"
and tasim: "ta1 ∼m ta2" by auto
let ?s2' = "((Running, x2'), m2')"
let ?s2'' = "((Running, x2''), m2'')"
let ?ta2 = "(convert_TA_initial (convert_obs_initial ta2))"
from red2 have "τtrsys.silent_moves (r2.init_fin t) r2.init_fin_τmove s2 ?s2'"
unfolding s2 ‹status = Running› by(rule r2.init_fin_silent_moves_RunningI)
moreover from red2' have "r2.init_fin t ?s2' ?ta2 ?s2''" by(rule r2.init_fin.NormalAction)
moreover from τ2 have "¬ r2.init_fin_τmove ?s2' ?ta2 ?s2''" by simp
moreover from bisim' have "t ⊢ s1' ≈i ?s2''"using ‹s1' = ((Running, x1'), m1')› by simp
moreover from tasim ‹tl1 = convert_TA_initial (convert_obs_initial ta1)›
have "ta_bisim init_fin_bisim tl1 ?ta2" by simp
ultimately show ?thesis by blast
next
case InitialThreadAction
with s1 s2 bisim show ?thesis by(auto simp del: split_paired_Ex)
next
case ThreadFinishAction
from final1_simulation[OF bisim] ‹final1 x1›
obtain x2' m2' where red2: "r2.silent_moves t (x2, m2) (x2', m2')"
and bisim': "t ⊢ (x1, m1) ≈ (x2', m2')"
and fin2: "final2 x2'" by auto
let ?s2' = "((Running, x2'), m2')"
let ?s2'' = "((Finished, x2'), m2')"
from red2 have "τtrsys.silent_moves (r2.init_fin t) r2.init_fin_τmove s2 ?s2'"
unfolding s2 ‹status = Running› by(rule r2.init_fin_silent_moves_RunningI)
moreover from fin2 have "r2.init_fin t ?s2' ⦃ThreadFinishAction⦄ ?s2''" ..
moreover have "¬ r2.init_fin_τmove ?s2' ⦃ThreadFinishAction⦄ ?s2''" by simp
moreover have "t ⊢ s1' ≈i ?s2''"
using ‹s1' = ((Finished, x1), m1)› fin2 ‹final1 x1› bisim' by simp
ultimately show ?thesis unfolding ‹tl1 = ⦃ThreadFinishAction⦄›
by(blast intro: ta_bisim_init_fin_bisim_ThreadFinishAction)
qed
qed
lemma init_fin_simulation2:
"⟦ t ⊢ s1 ≈i s2; r2.init_fin t s2 tl2 s2'; ¬ r2.init_fin_τmove s2 tl2 s2' ⟧
⟹ ∃s1' s1'' tl1. (τtrsys.silent_move (r1.init_fin t) r1.init_fin_τmove)⇧*⇧* s1 s1' ∧
r1.init_fin t s1' tl1 s1'' ∧ ¬ r1.init_fin_τmove s1' tl1 s1'' ∧
t ⊢ s1'' ≈i s2' ∧ ta_bisim init_fin_bisim tl1 tl2"
using FWdelay_bisimulation_obs.init_fin_simulation1[OF FWdelay_bisimulation_obs_flip]
unfolding flip_simps .
lemma init_fin_simulation_Wakeup1:
assumes bisim: "t ⊢ (sx1, m1) ≈i (sx2, m2)"
and wait: "sx1 ≈iw sx2"
and red1: "r1.init_fin t (sx1, m1) ta1 (sx1', m1')"
and wakeup: "Notified ∈ set ⦃ta1⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta1⦄⇘w⇙"
shows "∃ta2 sx2' m2'. r2.init_fin t (sx2, m2) ta2 (sx2', m2') ∧ t ⊢ (sx1', m1') ≈i (sx2', m2') ∧
ta_bisim init_fin_bisim ta1 ta2"
proof -
from bisim wait obtain status x1 x2
where sx1: "sx1 = (status, x1)"
and sx2: "sx2 = (status, x2)"
and Bisim: "t ⊢ (x1, m1) ≈ (x2, m2)"
and Wait: "x1 ≈w x2" by cases auto
from red1 wakeup sx1 obtain x1' ta1'
where sx1': "sx1' = (Running, x1')"
and status: "status = Running"
and Red1: "t ⊢ (x1, m1) -1-ta1'→ (x1', m1')"
and ta1: "ta1 = convert_TA_initial (convert_obs_initial ta1')"
and Wakeup: "Notified ∈ set ⦃ta1'⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta1'⦄⇘w⇙"
by cases auto
from simulation_Wakeup1[OF Bisim Wait Red1 Wakeup] obtain ta2' x2' m2'
where red2: "t ⊢ (x2, m2) -2-ta2'→ (x2', m2')"
and bisim': "t ⊢ (x1', m1') ≈ (x2', m2')"
and tasim: "ta1' ∼m ta2'" by blast
let ?sx2' = "(Running, x2')"
let ?ta2 = "convert_TA_initial (convert_obs_initial ta2')"
from red2 have "r2.init_fin t (sx2, m2) ?ta2 (?sx2', m2')" unfolding sx2 status ..
moreover from bisim' sx1' have "t ⊢ (sx1', m1') ≈i (?sx2', m2')" by simp
moreover from tasim ta1 have "ta_bisim init_fin_bisim ta1 ?ta2" by simp
ultimately show ?thesis by blast
qed
lemma init_fin_simulation_Wakeup2:
"⟦ t ⊢ (sx1, m1) ≈i (sx2, m2); sx1 ≈iw sx2; r2.init_fin t (sx2, m2) ta2 (sx2', m2');
Notified ∈ set ⦃ta2⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta2⦄⇘w⇙ ⟧
⟹ ∃ta1 sx1' m1'. r1.init_fin t (sx1, m1) ta1 (sx1', m1') ∧ t ⊢ (sx1', m1') ≈i (sx2', m2') ∧
ta_bisim init_fin_bisim ta1 ta2"
using FWdelay_bisimulation_obs.init_fin_simulation_Wakeup1[OF FWdelay_bisimulation_obs_flip]
unfolding flip_simps .
lemma init_fin_delay_bisimulation_obs:
"delay_bisimulation_obs (r1.init_fin t) (r2.init_fin t) (init_fin_bisim t) (ta_bisim init_fin_bisim)
r1.init_fin_τmove r2.init_fin_τmove"
by(unfold_locales)(erule (2) init_fin_simulation1 init_fin_simulation2)+
lemma init_fin_FWdelay_bisimulation_obs:
"FWdelay_bisimulation_obs r1.init_fin_final r1.init_fin r2.init_fin_final r2.init_fin init_fin_bisim init_fin_bisim_wait r1.init_fin_τmove r2.init_fin_τmove"
proof(intro FWdelay_bisimulation_obs.intro init_fin_FWdelay_bisimulation_final_base FWdelay_bisimulation_obs_axioms.intro init_fin_delay_bisimulation_obs)
fix t' sx m1 sxx m2 t sx1 sx2 sx1' ta1 sx1'' m1' sx2' ta2 sx2'' m2'
assume bisim: "t' ⊢ (sx, m1) ≈i (sxx, m2)"
and bisim1: "t ⊢ (sx1, m1) ≈i (sx2, m2)"
and red1: "τtrsys.silent_moves (r1.init_fin t) r1.init_fin_τmove (sx1, m1) (sx1', m1)"
and red1': "r1.init_fin t (sx1', m1) ta1 (sx1'', m1')"
and τ1: "¬ r1.init_fin_τmove (sx1', m1) ta1 (sx1'', m1')"
and red2: "τtrsys.silent_moves (r2.init_fin t) r2.init_fin_τmove (sx2, m2) (sx2', m2)"
and red2':"r2.init_fin t (sx2', m2) ta2 (sx2'', m2')"
and τ2: "¬ r2.init_fin_τmove (sx2', m2) ta2 (sx2'', m2')"
and bisim1': "t ⊢ (sx1'', m1') ≈i (sx2'', m2')"
and tasim: "ta_bisim init_fin_bisim ta1 ta2"
from bisim obtain status x xx
where sx:"sx = (status, x)"
and sxx: "sxx = (status, xx)"
and Bisim: "t' ⊢ (x, m1) ≈ (xx, m2)"
and Finish: "status = Finished ⟹ final1 x ∧ final2 xx"
by(cases sx)(cases sxx, auto simp add: init_fin_bisim_iff)
from bisim1 obtain status1 x1 x2
where sx1: "sx1 = (status1, x1)"
and sx2: "sx2 = (status1, x2)"
and Bisim1: "t ⊢ (x1, m1) ≈ (x2, m2)"
by(cases sx1)(cases sx2, auto simp add: init_fin_bisim_iff)
from bisim1' obtain status1' x1'' x2''
where sx1'': "sx1'' = (status1', x1'')"
and sx2'': "sx2'' = (status1', x2'')"
and Bisim1': "t ⊢ (x1'', m1') ≈ (x2'', m2')"
by(cases sx1'')(cases sx2'', auto simp add: init_fin_bisim_iff)
from red1 sx1 obtain x1' where sx1': "sx1' = (status1, x1')"
and Red1: "r1.silent_moves t (x1, m1) (x1', m1)"
by(cases sx1')(auto dest: r1.init_fin_silent_movesD)
from red2 sx2 obtain x2' where sx2': "sx2' = (status1, x2')"
and Red2: "r2.silent_moves t (x2, m2) (x2', m2)"
by(cases sx2')(auto dest: r2.init_fin_silent_movesD)
show "t' ⊢ (sx, m1') ≈i (sxx, m2')"
proof(cases "status1 = Running ∧ status1' = Running")
case True
with red1' sx1' sx1'' obtain ta1'
where Red1': "t ⊢ (x1', m1) -1-ta1'→ (x1'', m1')"
and ta1: "ta1 = convert_TA_initial (convert_obs_initial ta1')"
by cases auto
from red2' sx2' sx2'' True obtain ta2'
where Red2': "t ⊢ (x2', m2) -2-ta2'→ (x2'', m2')"
and ta2: "ta2 = convert_TA_initial (convert_obs_initial ta2')"
by cases auto
from τ1 sx1' sx1'' ta1 True have τ1':"¬ τmove1 (x1', m1) ta1' (x1'', m1')" by simp
from τ2 sx2' sx2'' ta2 True have τ2':"¬ τmove2 (x2', m2) ta2' (x2'', m2')" by simp
from tasim ta1 ta2 have "ta1' ∼m ta2'" by simp
with Bisim Bisim1 Red1 Red1' τ1' Red2 Red2' τ2' Bisim1'
have "t' ⊢ (x, m1') ≈ (xx, m2')" by(rule bisim_inv_red_other)
with True Finish show ?thesis unfolding sx sxx by(simp add: init_fin_bisim_iff)
next
case False
with red1' sx1' sx1'' have "m1' = m1" by cases auto
moreover from red2' sx2' sx2'' False have "m2' = m2" by cases auto
ultimately show ?thesis using bisim by simp
qed
next
fix t sx1 m1 sx2 m2 sx1' ta1 sx1'' m1' sx2' ta2 sx2'' m2' w
assume bisim: "t ⊢ (sx1, m1) ≈i (sx2, m2)"
and red1: "τtrsys.silent_moves (r1.init_fin t) r1.init_fin_τmove (sx1, m1) (sx1', m1)"
and red1': "r1.init_fin t (sx1', m1) ta1 (sx1'', m1')"
and τ1: "¬ r1.init_fin_τmove (sx1', m1) ta1 (sx1'', m1')"
and red2: "τtrsys.silent_moves (r2.init_fin t) r2.init_fin_τmove (sx2, m2) (sx2', m2)"
and red2': "r2.init_fin t (sx2', m2) ta2 (sx2'', m2')"
and τ2: "¬ r2.init_fin_τmove (sx2', m2) ta2 (sx2'', m2')"
and bisim': "t ⊢ (sx1'', m1') ≈i (sx2'', m2')"
and tasim: "ta_bisim init_fin_bisim ta1 ta2"
and suspend1: "Suspend w ∈ set ⦃ta1⦄⇘w⇙"
and suspend2: "Suspend w ∈ set ⦃ta2⦄⇘w⇙"
from bisim obtain status x1 x2
where sx1: "sx1 = (status, x1)"
and sx2: "sx2 = (status, x2)"
and Bisim: "t ⊢ (x1, m1) ≈ (x2, m2)"
by(cases sx1)(cases sx2, auto simp add: init_fin_bisim_iff)
from bisim' obtain status' x1'' x2''
where sx1'': "sx1'' = (status', x1'')"
and sx2'': "sx2'' = (status', x2'')"
and Bisim': "t ⊢ (x1'', m1') ≈ (x2'', m2')"
by(cases sx1'')(cases sx2'', auto simp add: init_fin_bisim_iff)
from red1 sx1 obtain x1' where sx1': "sx1' = (status, x1')"
and Red1: "r1.silent_moves t (x1, m1) (x1', m1)"
by(cases sx1')(auto dest: r1.init_fin_silent_movesD)
from red2 sx2 obtain x2' where sx2': "sx2' = (status, x2')"
and Red2: "r2.silent_moves t (x2, m2) (x2', m2)"
by(cases sx2')(auto dest: r2.init_fin_silent_movesD)
from red1' sx1' sx1'' suspend1 obtain ta1'
where Red1': "t ⊢ (x1', m1) -1-ta1'→ (x1'', m1')"
and ta1: "ta1 = convert_TA_initial (convert_obs_initial ta1')"
and Suspend1: "Suspend w ∈ set ⦃ta1'⦄⇘w⇙"
and status: "status = Running" "status' = Running" by cases auto
from red2' sx2' sx2'' suspend2 obtain ta2'
where Red2': "t ⊢ (x2', m2) -2-ta2'→ (x2'', m2')"
and ta2: "ta2 = convert_TA_initial (convert_obs_initial ta2')"
and Suspend2: "Suspend w ∈ set ⦃ta2'⦄⇘w⇙" by cases auto
from τ1 sx1' sx1'' ta1 status have τ1':"¬ τmove1 (x1', m1) ta1' (x1'', m1')" by simp
from τ2 sx2' sx2'' ta2 status have τ2':"¬ τmove2 (x2', m2) ta2' (x2'', m2')" by simp
from tasim ta1 ta2 have "ta1' ∼m ta2'" by simp
with Bisim Red1 Red1' τ1' Red2 Red2' τ2' Bisim' have "x1'' ≈w x2''"
using Suspend1 Suspend2 by(rule bisim_waitI)
thus "sx1'' ≈iw sx2''" using sx1'' sx2'' status by simp
next
fix t sx1 m1 sx2 m2 ta1 sx1' m1'
assume "t ⊢ (sx1, m1) ≈i (sx2, m2)" and "sx1 ≈iw sx2"
and "r1.init_fin t (sx1, m1) ta1 (sx1', m1')"
and "Notified ∈ set ⦃ta1⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta1⦄⇘w⇙"
thus "∃ta2 sx2' m2'. r2.init_fin t (sx2, m2) ta2 (sx2', m2') ∧ t ⊢ (sx1', m1') ≈i (sx2', m2') ∧
ta_bisim init_fin_bisim ta1 ta2"
by(rule init_fin_simulation_Wakeup1)
next
fix t sx1 m1 sx2 m2 ta2 sx2' m2'
assume "t ⊢ (sx1, m1) ≈i (sx2, m2)" and "sx1 ≈iw sx2"
and "r2.init_fin t (sx2, m2) ta2 (sx2', m2')"
and "Notified ∈ set ⦃ta2⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta2⦄⇘w⇙"
thus "∃ta1 sx1' m1'. r1.init_fin t (sx1, m1) ta1 (sx1', m1') ∧ t ⊢ (sx1', m1') ≈i (sx2', m2') ∧
ta_bisim init_fin_bisim ta1 ta2"
by(rule init_fin_simulation_Wakeup2)
next
show "(∃sx1. r1.init_fin_final sx1) = (∃sx2. r2.init_fin_final sx2)"
using ex_final1_conv_ex_final2 by(auto)
qed
end
context FWdelay_bisimulation_diverge begin
lemma init_fin_simulation_silent1:
"⟦ t ⊢ sxm1 ≈i sxm2; τtrsys.silent_move (r1.init_fin t) r1.init_fin_τmove sxm1 sxm1' ⟧
⟹ ∃sxm2'. τtrsys.silent_moves (r2.init_fin t) r2.init_fin_τmove sxm2 sxm2' ∧ t ⊢ sxm1' ≈i sxm2'"
by(cases sxm1')(auto 4 4 elim!: init_fin_bisim.cases dest!: r1.init_fin_silent_moveD dest: simulation_silent1 intro!: r2.init_fin_silent_moves_RunningI)
lemma init_fin_simulation_silent2:
"⟦ t ⊢ sxm1 ≈i sxm2; τtrsys.silent_move (r2.init_fin t) r2.init_fin_τmove sxm2 sxm2' ⟧
⟹ ∃sxm1'. τtrsys.silent_moves (r1.init_fin t) r1.init_fin_τmove sxm1 sxm1' ∧ t ⊢ sxm1' ≈i sxm2'"
using FWdelay_bisimulation_diverge.init_fin_simulation_silent1[OF FWdelay_bisimulation_diverge_flip]
unfolding flip_simps .
lemma init_fin_τdiverge_bisim_inv:
"t ⊢ sxm1 ≈i sxm2
⟹ τtrsys.τdiverge (r1.init_fin t) r1.init_fin_τmove sxm1 =
τtrsys.τdiverge (r2.init_fin t) r2.init_fin_τmove sxm2"
by(cases sxm1)(cases sxm2, auto simp add: r1.init_fin_τdiverge_conv r2.init_fin_τdiverge_conv init_fin_bisim_iff τdiverge_bisim_inv)
lemma init_fin_delay_bisimulation_diverge:
"delay_bisimulation_diverge (r1.init_fin t) (r2.init_fin t) (init_fin_bisim t) (ta_bisim init_fin_bisim)
r1.init_fin_τmove r2.init_fin_τmove"
by(blast intro: delay_bisimulation_diverge.intro init_fin_delay_bisimulation_obs delay_bisimulation_diverge_axioms.intro init_fin_simulation_silent1 init_fin_simulation_silent2 init_fin_τdiverge_bisim_inv del: iffI)+
lemma init_fin_FWdelay_bisimulation_diverge:
"FWdelay_bisimulation_diverge r1.init_fin_final r1.init_fin r2.init_fin_final r2.init_fin init_fin_bisim init_fin_bisim_wait r1.init_fin_τmove r2.init_fin_τmove"
by(intro FWdelay_bisimulation_diverge.intro init_fin_FWdelay_bisimulation_obs FWdelay_bisimulation_diverge_axioms.intro init_fin_delay_bisimulation_diverge)
end
context FWbisimulation begin
lemma init_fin_simulation1:
assumes "t ⊢ s1 ≈i s2" and "r1.init_fin t s1 tl1 s1'"
shows "∃s2' tl2. r2.init_fin t s2 tl2 s2' ∧ t ⊢ s1' ≈i s2' ∧ ta_bisim init_fin_bisim tl1 tl2"
using init_fin_simulation1[OF assms] by(auto simp add: τmoves_False init_fin_τmoves_False)
lemma init_fin_simulation2:
"⟦ t ⊢ s1 ≈i s2; r2.init_fin t s2 tl2 s2' ⟧
⟹ ∃s1' tl1. r1.init_fin t s1 tl1 s1' ∧ t ⊢ s1' ≈i s2' ∧ ta_bisim init_fin_bisim tl1 tl2"
using FWbisimulation.init_fin_simulation1[OF FWbisimulation_flip]
unfolding flip_simps .
lemma init_fin_bisimulation:
"bisimulation (r1.init_fin t) (r2.init_fin t) (init_fin_bisim t) (ta_bisim init_fin_bisim)"
by(unfold_locales)(erule (1) init_fin_simulation1 init_fin_simulation2)+
lemma init_fin_FWbisimulation:
"FWbisimulation r1.init_fin_final r1.init_fin r2.init_fin_final r2.init_fin init_fin_bisim"
proof(intro FWbisimulation.intro r1.multithreaded_init_fin r2.multithreaded_init_fin FWbisimulation_axioms.intro init_fin_bisimulation)
fix t sx1 m1 sx2 m2
assume "t ⊢ (sx1, m1) ≈i (sx2, m2)"
thus "r1.init_fin_final sx1 = r2.init_fin_final sx2"
by cases simp_all
next
fix t' sx m1 sxx m2 t sx1 sx2 ta1 sx1' m1' ta2 sx2' m2'
assume "t' ⊢ (sx, m1) ≈i (sxx, m2)" "t ⊢ (sx1, m1) ≈i (sx2, m2)"
and "r1.init_fin t (sx1, m1) ta1 (sx1', m1')"
and "r2.init_fin t (sx2, m2) ta2 (sx2', m2')"
and "t ⊢ (sx1', m1') ≈i (sx2', m2')"
and "ta_bisim init_fin_bisim ta1 ta2"
from FWdelay_bisimulation_obs.bisim_inv_red_other
[OF init_fin_FWdelay_bisimulation_obs, OF this(1-2) _ this(3) _ _ this(4) _ this(5-6)]
show "t' ⊢ (sx, m1') ≈i (sxx, m2')" by(simp add: init_fin_τmoves_False)
next
show "(∃sx1. r1.init_fin_final sx1) = (∃sx2. r2.init_fin_final sx2)"
using ex_final1_conv_ex_final2 by(auto)
qed
end
end
Theory Semilat
chapter ‹Data Flow Analysis Framework \label{cha:bv}›
section ‹Semilattices›
theory Semilat
imports Main "HOL-Library.While_Combinator"
begin
type_synonym 'a ord = "'a ⇒ 'a ⇒ bool"
type_synonym 'a binop = "'a ⇒ 'a ⇒ 'a"
type_synonym 'a sl = "'a set × 'a ord × 'a binop"
definition lesub :: "'a ⇒ 'a ord ⇒ 'a ⇒ bool"
where "lesub x r y ⟷ r x y"
definition lesssub :: "'a ⇒ 'a ord ⇒ 'a ⇒ bool"
where "lesssub x r y ⟷ lesub x r y ∧ x ≠ y"
definition plussub :: "'a ⇒ ('a ⇒ 'b ⇒ 'c) ⇒ 'b ⇒ 'c"
where "plussub x f y = f x y"
notation (ASCII)
"lesub" ("(_ /<='__ _)" [50, 1000, 51] 50) and
"lesssub" ("(_ /<'__ _)" [50, 1000, 51] 50) and
"plussub" ("(_ /+'__ _)" [65, 1000, 66] 65)
notation
"lesub" ("(_ /⊑⇘_⇙ _)" [50, 0, 51] 50) and
"lesssub" ("(_ /⊏⇘_⇙ _)" [50, 0, 51] 50) and
"plussub" ("(_ /⊔⇘_⇙ _)" [65, 0, 66] 65)
abbreviation (input)
lesub1 :: "'a ⇒ 'a ord ⇒ 'a ⇒ bool" ("(_ /⊑⇩_ _)" [50, 1000, 51] 50)
where "x ⊑⇩r y == x ⊑⇘r⇙ y"
abbreviation (input)
lesssub1 :: "'a ⇒ 'a ord ⇒ 'a ⇒ bool" ("(_ /⊏⇩_ _)" [50, 1000, 51] 50)
where "x ⊏⇩r y == x ⊏⇘r⇙ y"
abbreviation (input)
plussub1 :: "'a ⇒ ('a ⇒ 'b ⇒ 'c) ⇒ 'b ⇒ 'c" ("(_ /⊔⇩_ _)" [65, 1000, 66] 65)
where "x ⊔⇩f y == x ⊔⇘f⇙ y"
definition ord :: "('a × 'a) set ⇒ 'a ord"
where
"ord r = (λx y. (x,y) ∈ r)"
definition order :: "'a ord ⇒ bool"
where
"order r ⟷ (∀x. x ⊑⇩r x) ∧ (∀x y. x ⊑⇩r y ∧ y ⊑⇩r x ⟶ x=y) ∧ (∀x y z. x ⊑⇩r y ∧ y ⊑⇩r z ⟶ x ⊑⇩r z)"
definition top :: "'a ord ⇒ 'a ⇒ bool"
where
"top r T ⟷ (∀x. x ⊑⇩r T)"
definition acc :: "'a set ⇒ 'a ord ⇒ bool"
where
"acc A r ⟷ wf {(y,x). x ∈ A ∧ y ∈ A ∧ x ⊏⇩r y}"
definition closed :: "'a set ⇒ 'a binop ⇒ bool"
where
"closed A f ⟷ (∀x∈A. ∀y∈A. x ⊔⇩f y ∈ A)"
definition semilat :: "'a sl ⇒ bool"
where
"semilat = (λ(A,r,f). order r ∧ closed A f ∧
(∀x∈A. ∀y∈A. x ⊑⇩r x ⊔⇩f y) ∧
(∀x∈A. ∀y∈A. y ⊑⇩r x ⊔⇩f y) ∧
(∀x∈A. ∀y∈A. ∀z∈A. x ⊑⇩r z ∧ y ⊑⇩r z ⟶ x ⊔⇩f y ⊑⇩r z))"
definition is_ub :: "('a × 'a) set ⇒ 'a ⇒ 'a ⇒ 'a ⇒ bool"
where
"is_ub r x y u ⟷ (x,u)∈r ∧ (y,u)∈r"
definition is_lub :: "('a × 'a) set ⇒ 'a ⇒ 'a ⇒ 'a ⇒ bool"
where
"is_lub r x y u ⟷ is_ub r x y u ∧ (∀z. is_ub r x y z ⟶ (u,z)∈r)"
definition some_lub :: "('a × 'a) set ⇒ 'a ⇒ 'a ⇒ 'a"
where
"some_lub r x y = (SOME z. is_lub r x y z)"
locale Semilat =
fixes A :: "'a set"
fixes r :: "'a ord"
fixes f :: "'a binop"
assumes semilat: "semilat (A, r, f)"
lemma order_refl [simp, intro]: "order r ⟹ x ⊑⇩r x"
by (unfold order_def) (simp (no_asm_simp))
lemma order_antisym: "⟦ order r; x ⊑⇩r y; y ⊑⇩r x ⟧ ⟹ x = y"
by (unfold order_def) (simp (no_asm_simp))
lemma order_trans: "⟦ order r; x ⊑⇩r y; y ⊑⇩r z ⟧ ⟹ x ⊑⇩r z"
by (unfold order_def) blast
lemma order_less_irrefl [intro, simp]: "order r ⟹ ¬ x ⊏⇩r x"
by (unfold order_def lesssub_def) blast
lemma order_less_trans: "⟦ order r; x ⊏⇩r y; y ⊏⇩r z ⟧ ⟹ x ⊏⇩r z"
by (unfold order_def lesssub_def) blast
lemma topD [simp, intro]: "top r T ⟹ x ⊑⇩r T"
by (simp add: top_def)
lemma top_le_conv [simp]: "⟦ order r; top r T ⟧ ⟹ (T ⊑⇩r x) = (x = T)"
by (blast intro: order_antisym)
lemma semilat_Def:
"semilat(A,r,f) ⟷ order r ∧ closed A f ∧
(∀x∈A. ∀y∈A. x ⊑⇩r x ⊔⇩f y) ∧
(∀x∈A. ∀y∈A. y ⊑⇩r x ⊔⇩f y) ∧
(∀x∈A. ∀y∈A. ∀z∈A. x ⊑⇩r z ∧ y ⊑⇩r z ⟶ x ⊔⇩f y ⊑⇩r z)"
by (unfold semilat_def) clarsimp
lemma (in Semilat) orderI [simp, intro]: "order r"
using semilat by (simp add: semilat_Def)
lemma (in Semilat) closedI [simp, intro]: "closed A f"
using semilat by (simp add: semilat_Def)
lemma closedD: "⟦ closed A f; x∈A; y∈A ⟧ ⟹ x ⊔⇩f y ∈ A"
by (unfold closed_def) blast
lemma closed_UNIV [simp]: "closed UNIV f"
by (simp add: closed_def)
lemma (in Semilat) closed_f [simp, intro]: "⟦x ∈ A; y ∈ A⟧ ⟹ x ⊔⇩f y ∈ A"
by (simp add: closedD [OF closedI])
lemma (in Semilat) refl_r [intro, simp]: "x ⊑⇩r x" by simp
lemma (in Semilat) antisym_r [intro?]: "⟦ x ⊑⇩r y; y ⊑⇩r x ⟧ ⟹ x = y"
by (rule order_antisym) auto
lemma (in Semilat) trans_r [trans, intro?]: "⟦x ⊑⇩r y; y ⊑⇩r z⟧ ⟹ x ⊑⇩r z"
by (auto intro: order_trans)
lemma (in Semilat) ub1 [simp, intro?]: "⟦ x ∈ A; y ∈ A ⟧ ⟹ x ⊑⇩r x ⊔⇩f y"
by (insert semilat) (unfold semilat_Def, simp)
lemma (in Semilat) ub2 [simp, intro?]: "⟦ x ∈ A; y ∈ A ⟧ ⟹ y ⊑⇩r x ⊔⇩f y"
by (insert semilat) (unfold semilat_Def, simp)
lemma (in Semilat) lub [simp, intro?]:
"⟦ x ⊑⇩r z; y ⊑⇩r z; x ∈ A; y ∈ A; z ∈ A ⟧ ⟹ x ⊔⇩f y ⊑⇩r z"
by (insert semilat) (unfold semilat_Def, simp)
lemma (in Semilat) plus_le_conv [simp]:
"⟦ x ∈ A; y ∈ A; z ∈ A ⟧ ⟹ (x ⊔⇩f y ⊑⇩r z) = (x ⊑⇩r z ∧ y ⊑⇩r z)"
by (blast intro: ub1 ub2 lub order_trans)
lemma (in Semilat) le_iff_plus_unchanged:
assumes "x ∈ A" and "y ∈ A"
shows "x ⊑⇩r y ⟷ x ⊔⇩f y = y" (is "?P ⟷ ?Q")
proof
assume ?P
with assms show ?Q by (blast intro: antisym_r lub ub2)
next
assume ?Q
then have "y = x ⊔⇘f⇙ y" by simp
moreover from assms have "x ⊑⇘r⇙ x ⊔⇘f⇙ y" by simp
ultimately show ?P by simp
qed
lemma (in Semilat) le_iff_plus_unchanged2:
assumes "x ∈ A" and "y ∈ A"
shows "x ⊑⇩r y ⟷ y ⊔⇩f x = y" (is "?P ⟷ ?Q")
proof
assume ?P
with assms show ?Q by (blast intro: antisym_r lub ub1)
next
assume ?Q
then have "y = y ⊔⇘f⇙ x" by simp
moreover from assms have "x ⊑⇘r⇙ y ⊔⇘f⇙ x" by simp
ultimately show ?P by simp
qed
lemma (in Semilat) plus_assoc [simp]:
assumes a: "a ∈ A" and b: "b ∈ A" and c: "c ∈ A"
shows "a ⊔⇩f (b ⊔⇩f c) = a ⊔⇩f b ⊔⇩f c"
proof -
from a b have ab: "a ⊔⇩f b ∈ A" ..
from this c have abc: "(a ⊔⇩f b) ⊔⇩f c ∈ A" ..
from b c have bc: "b ⊔⇩f c ∈ A" ..
from a this have abc': "a ⊔⇩f (b ⊔⇩f c) ∈ A" ..
show ?thesis
proof
show "a ⊔⇩f (b ⊔⇩f c) ⊑⇩r (a ⊔⇩f b) ⊔⇩f c"
proof -
from a b have "a ⊑⇩r a ⊔⇩f b" ..
also from ab c have "… ⊑⇩r … ⊔⇩f c" ..
finally have "a<": "a ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" .
from a b have "b ⊑⇩r a ⊔⇩f b" ..
also from ab c have "… ⊑⇩r … ⊔⇩f c" ..
finally have "b<": "b ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" .
from ab c have "c<": "c ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" ..
from "b<" "c<" b c abc have "b ⊔⇩f c ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" ..
from "a<" this a bc abc show ?thesis ..
qed
show "(a ⊔⇩f b) ⊔⇩f c ⊑⇩r a ⊔⇩f (b ⊔⇩f c)"
proof -
from b c have "b ⊑⇩r b ⊔⇩f c" ..
also from a bc have "… ⊑⇩r a ⊔⇩f …" ..
finally have "b<": "b ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" .
from b c have "c ⊑⇩r b ⊔⇩f c" ..
also from a bc have "… ⊑⇩r a ⊔⇩f …" ..
finally have "c<": "c ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" .
from a bc have "a<": "a ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" ..
from "a<" "b<" a b abc' have "a ⊔⇩f b ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" ..
from this "c<" ab c abc' show ?thesis ..
qed
qed
qed
lemma (in Semilat) plus_com_lemma:
"⟦a ∈ A; b ∈ A⟧ ⟹ a ⊔⇩f b ⊑⇩r b ⊔⇩f a"
proof -
assume a: "a ∈ A" and b: "b ∈ A"
from b a have "a ⊑⇩r b ⊔⇩f a" ..
moreover from b a have "b ⊑⇩r b ⊔⇩f a" ..
moreover note a b
moreover from b a have "b ⊔⇩f a ∈ A" ..
ultimately show ?thesis ..
qed
lemma (in Semilat) plus_commutative:
"⟦a ∈ A; b ∈ A⟧ ⟹ a ⊔⇩f b = b ⊔⇩f a"
by(blast intro: order_antisym plus_com_lemma)
lemma is_lubD:
"is_lub r x y u ⟹ is_ub r x y u ∧ (∀z. is_ub r x y z ⟶ (u,z) ∈ r)"
by (simp add: is_lub_def)
lemma is_ubI:
"⟦ (x,u) ∈ r; (y,u) ∈ r ⟧ ⟹ is_ub r x y u"
by (simp add: is_ub_def)
lemma is_ubD:
"is_ub r x y u ⟹ (x,u) ∈ r ∧ (y,u) ∈ r"
by (simp add: is_ub_def)
lemma is_lub_bigger1 [iff]:
"is_lub (r^* ) x y y = ((x,y)∈r^* )"
by (unfold is_lub_def is_ub_def) blast
lemma is_lub_bigger2 [iff]:
"is_lub (r^* ) x y x = ((y,x)∈r^* )"
by (unfold is_lub_def is_ub_def) blast
lemma extend_lub:
assumes "single_valued r"
and "is_lub (r⇧*) x y u"
and "(x', x) ∈ r"
shows "∃v. is_lub (r⇧*) x' y v"
proof (cases "(y, x) ∈ r⇧*")
case True show ?thesis
proof (cases "(y, x') ∈ r⇧*")
case True with ‹(y, x) ∈ r⇧*› show ?thesis by blast
next
case False with True assms show ?thesis
by (unfold is_lub_def is_ub_def) (blast elim: converse_rtranclE dest: single_valuedD)
qed
next
case False
from assms have "(x', u) ∈ r⇧*" and "(y, u) ∈ r⇧*"
by (auto simp add: is_lub_def is_ub_def)
moreover from False assms have "⋀z. (x', z) ∈ r⇧* ⟹ (y, z) ∈ r⇧* ⟹ (u, z) ∈ r⇧*"
by (unfold is_lub_def is_ub_def) (blast intro: rtrancl_into_rtrancl
converse_rtrancl_into_rtrancl elim: converse_rtranclE dest: single_valuedD)
ultimately have "is_lub (r⇧*) x' y u"
by (unfold is_lub_def is_ub_def) blast
then show ?thesis ..
qed
lemma single_valued_has_lubs:
assumes "single_valued r"
and in_r: "(x, u) ∈ r⇧*" "(y, u) ∈ r⇧*"
shows "∃z. is_lub (r⇧*) x y z"
using in_r proof (induct arbitrary: y rule: converse_rtrancl_induct)
case base then show ?case by (induct rule: converse_rtrancl_induct)
(blast, blast intro: converse_rtrancl_into_rtrancl)
next
case step with ‹single_valued r› show ?case by (blast intro: extend_lub)
qed
lemma some_lub_conv:
"⟦ acyclic r; is_lub (r^* ) x y u ⟧ ⟹ some_lub (r^* ) x y = u"
apply (simp only: some_lub_def is_lub_def)
apply (rule someI2)
apply (simp only: is_lub_def)
apply (blast intro: antisymD dest!: acyclic_impl_antisym_rtrancl)
done
lemma is_lub_some_lub:
"⟦ single_valued r; acyclic r; (x,u)∈r^*; (y,u)∈r^* ⟧
⟹ is_lub (r^* ) x y (some_lub (r^* ) x y)"
by (fastforce dest: single_valued_has_lubs simp add: some_lub_conv)
subsection‹An executable lub-finder›
definition exec_lub :: "('a * 'a) set ⇒ ('a ⇒ 'a) ⇒ 'a binop"
where
"exec_lub r f x y = while (λz. (x,z) ∉ r⇧*) f y"
lemma exec_lub_refl: "exec_lub r f T T = T"
by (simp add: exec_lub_def while_unfold)
lemma acyclic_single_valued_finite:
"⟦acyclic r; single_valued r; (x,y) ∈ r⇧*⟧
⟹ finite (r ∩ {a. (x, a) ∈ r⇧*} × {b. (b, y) ∈ r⇧*})"
apply(erule converse_rtrancl_induct)
apply(rule_tac B = "{}" in finite_subset)
apply(simp only:acyclic_def)
apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
apply simp
apply(rename_tac x x')
apply(subgoal_tac "r ∩ {a. (x,a) ∈ r⇧*} × {b. (b,y) ∈ r⇧*} =
insert (x,x') (r ∩ {a. (x', a) ∈ r⇧*} × {b. (b, y) ∈ r⇧*})")
apply simp
apply(blast intro:converse_rtrancl_into_rtrancl
elim:converse_rtranclE dest:single_valuedD)
done
lemma exec_lub_conv:
"⟦ acyclic r; ∀x y. (x,y) ∈ r ⟶ f x = y; is_lub (r⇧*) x y u ⟧ ⟹
exec_lub r f x y = u"
apply(unfold exec_lub_def)
apply(rule_tac P = "λz. (y,z) ∈ r⇧* ∧ (z,u) ∈ r⇧*" and
r = "(r ∩ {(a,b). (y,a) ∈ r⇧* ∧ (b,u) ∈ r⇧*})^-1" in while_rule)
apply(blast dest: is_lubD is_ubD)
apply(erule conjE)
apply(erule_tac z = u in converse_rtranclE)
apply(blast dest: is_lubD is_ubD)
apply(blast dest:rtrancl_into_rtrancl)
apply(rename_tac s)
apply(subgoal_tac "is_ub (r⇧*) x y s")
prefer 2 apply(simp add:is_ub_def)
apply(subgoal_tac "(u, s) ∈ r⇧*")
prefer 2 apply(blast dest:is_lubD)
apply(erule converse_rtranclE)
apply blast
apply(simp only:acyclic_def)
apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
apply(rule finite_acyclic_wf)
apply simp
apply(erule acyclic_single_valued_finite)
apply(blast intro:single_valuedI)
apply(simp add:is_lub_def is_ub_def)
apply simp
apply(erule acyclic_subset)
apply blast
apply simp
apply(erule conjE)
apply(erule_tac z = u in converse_rtranclE)
apply(blast dest: is_lubD is_ubD)
apply(blast dest:rtrancl_into_rtrancl)
done
lemma is_lub_exec_lub:
"⟦ single_valued r; acyclic r; (x,u):r^*; (y,u):r^*; ∀x y. (x,y) ∈ r ⟶ f x = y ⟧
⟹ is_lub (r^* ) x y (exec_lub r f x y)"
by (fastforce dest: single_valued_has_lubs simp add: exec_lub_conv)
end
Theory Err
section ‹The Error Type›
theory Err
imports Semilat
begin
datatype 'a err = Err | OK 'a
type_synonym 'a ebinop = "'a ⇒ 'a ⇒ 'a err"
type_synonym 'a esl = "'a set × 'a ord × 'a ebinop"
primrec ok_val :: "'a err ⇒ 'a"
where
"ok_val (OK x) = x"
definition lift :: "('a ⇒ 'b err) ⇒ ('a err ⇒ 'b err)"
where
"lift f e = (case e of Err ⇒ Err | OK x ⇒ f x)"
definition lift2 :: "('a ⇒ 'b ⇒ 'c err) ⇒ 'a err ⇒ 'b err ⇒ 'c err"
where
"lift2 f e⇩1 e⇩2 =
(case e⇩1 of Err ⇒ Err | OK x ⇒ (case e⇩2 of Err ⇒ Err | OK y ⇒ f x y))"
definition le :: "'a ord ⇒ 'a err ord"
where
"le r e⇩1 e⇩2 =
(case e⇩2 of Err ⇒ True | OK y ⇒ (case e⇩1 of Err ⇒ False | OK x ⇒ x ⊑⇩r y))"
definition sup :: "('a ⇒ 'b ⇒ 'c) ⇒ ('a err ⇒ 'b err ⇒ 'c err)"
where
"sup f = lift2 (λx y. OK (x ⊔⇩f y))"
definition err :: "'a set ⇒ 'a err set"
where
"err A = insert Err {OK x|x. x∈A}"
definition esl :: "'a sl ⇒ 'a esl"
where
"esl = (λ(A,r,f). (A, r, λx y. OK(f x y)))"
definition sl :: "'a esl ⇒ 'a err sl"
where
"sl = (λ(A,r,f). (err A, le r, lift2 f))"
abbreviation
err_semilat :: "'a esl ⇒ bool" where
"err_semilat L == semilat(sl L)"
primrec strict :: "('a ⇒ 'b err) ⇒ ('a err ⇒ 'b err)"
where
"strict f Err = Err"
| "strict f (OK x) = f x"
lemma err_def':
"err A = insert Err {x. ∃y∈A. x = OK y}"
proof -
have eq: "err A = insert Err {x. ∃y∈A. x = OK y}"
by (unfold err_def) blast
show "err A = insert Err {x. ∃y∈A. x = OK y}" by (simp add: eq)
qed
lemma strict_Some [simp]:
"(strict f x = OK y) = (∃z. x = OK z ∧ f z = OK y)"
by (cases x, auto)
lemma not_Err_eq: "(x ≠ Err) = (∃a. x = OK a)"
by (cases x) auto
lemma not_OK_eq: "(∀y. x ≠ OK y) = (x = Err)"
by (cases x) auto
lemma unfold_lesub_err: "e1 ⊑⇘le r⇙ e2 = le r e1 e2"
by (simp add: lesub_def)
lemma le_err_refl: "∀x. x ⊑⇩r x ⟹ e ⊑⇘le r⇙ e"
apply (unfold lesub_def le_def)
apply (simp split: err.split)
done
lemma le_err_trans [rule_format]:
"order r ⟹ e1 ⊑⇘le r⇙ e2 ⟶ e2 ⊑⇘le r⇙ e3 ⟶ e1 ⊑⇘le r⇙ e3"
apply (unfold unfold_lesub_err le_def)
apply (simp split: err.split)
apply (blast intro: order_trans)
done
lemma le_err_antisym [rule_format]:
"order r ⟹ e1 ⊑⇘le r⇙ e2 ⟶ e2 ⊑⇘le r⇙ e1 ⟶ e1=e2"
apply (unfold unfold_lesub_err le_def)
apply (simp split: err.split)
apply (blast intro: order_antisym)
done
lemma OK_le_err_OK: "(OK x ⊑⇘le r⇙ OK y) = (x ⊑⇩r y)"
by (simp add: unfold_lesub_err le_def)
lemma order_le_err [iff]: "order(le r) = order r"
apply (rule iffI)
apply (subst order_def)
apply (blast dest: order_antisym OK_le_err_OK [THEN iffD2]
intro: order_trans OK_le_err_OK [THEN iffD1])
apply (subst order_def)
apply (blast intro: le_err_refl le_err_trans le_err_antisym
dest: order_refl)
done
lemma le_Err [iff]: "e ⊑⇘le r⇙ Err"
by (simp add: unfold_lesub_err le_def)
lemma Err_le_conv [iff]: "Err ⊑⇘le r⇙ e = (e = Err)"
by (simp add: unfold_lesub_err le_def split: err.split)
lemma le_OK_conv [iff]: "e ⊑⇘le r⇙ OK x = (∃y. e = OK y ∧ y ⊑⇩r x)"
by (simp add: unfold_lesub_err le_def split: err.split)
lemma OK_le_conv: "OK x ⊑⇘le r⇙ e = (e = Err ∨ (∃y. e = OK y ∧ x ⊑⇩r y))"
by (simp add: unfold_lesub_err le_def split: err.split)
lemma top_Err [iff]: "top (le r) Err"
by (simp add: top_def)
lemma OK_less_conv [rule_format, iff]:
"OK x ⊏⇘le r⇙ e = (e=Err ∨ (∃y. e = OK y ∧ x ⊏⇩r y))"
by (simp add: lesssub_def lesub_def le_def split: err.split)
lemma not_Err_less [rule_format, iff]: "¬(Err ⊏⇘le r⇙ x)"
by (simp add: lesssub_def lesub_def le_def split: err.split)
lemma semilat_errI [intro]: assumes "Semilat A r f"
shows "semilat(err A, le r, lift2(λx y. OK(f x y)))"
proof -
interpret Semilat A r f by fact
show ?thesis
apply(insert semilat)
apply (simp only: semilat_Def closed_def plussub_def lesub_def
lift2_def le_def)
apply (simp add: err_def' split: err.split)
done
qed
lemma err_semilat_eslI_aux:
assumes "Semilat A r f" shows "err_semilat(esl(A,r,f))"
proof -
interpret Semilat A r f by fact
show ?thesis
apply (unfold sl_def esl_def)
apply (simp add: semilat_errI [OF ‹Semilat A r f›])
done
qed
lemma err_semilat_eslI [intro, simp]:
"semilat L ⟹ err_semilat (esl L)"
apply (cases L) apply simp
apply (drule Semilat.intro)
apply (simp add: err_semilat_eslI_aux split_tupled_all)
done
lemma acc_err [simp, intro!]: "acc A r ⟹ acc (err A) (le r)"
apply (unfold acc_def lesub_def le_def lesssub_def)
apply (simp add: wf_eq_minimal split: err.split)
apply clarify
apply (case_tac "Err : Q")
apply blast
apply (erule_tac x = "{a . OK a : Q}" in allE)
apply (case_tac "x")
apply fast
apply (auto simp: err_def)
done
lemma Err_in_err [iff]: "Err : err A"
by (simp add: err_def')
lemma Ok_in_err [iff]: "(OK x ∈ err A) = (x∈A)"
by (auto simp add: err_def')
subsection ‹lift›
lemma lift_in_errI:
"⟦ e ∈ err S; ∀x∈S. e = OK x ⟶ f x ∈ err S ⟧ ⟹ lift f e ∈ err S"
apply (unfold lift_def)
apply (simp split: err.split)
apply blast
done
lemma Err_lift2 [simp]: "Err ⊔⇘lift2 f⇙ x = Err"
by (simp add: lift2_def plussub_def)
lemma lift2_Err [simp]: "x ⊔⇘lift2 f⇙ Err = Err"
by (simp add: lift2_def plussub_def split: err.split)
lemma OK_lift2_OK [simp]: "OK x ⊔⇘lift2 f⇙ OK y = x ⊔⇩f y"
by (simp add: lift2_def plussub_def split: err.split)
subsection ‹sup›
lemma Err_sup_Err [simp]: "Err ⊔⇘sup f⇙ x = Err"
by (simp add: plussub_def sup_def lift2_def)
lemma Err_sup_Err2 [simp]: "x ⊔⇘sup f⇙ Err = Err"
by (simp add: plussub_def sup_def lift2_def split: err.split)
lemma Err_sup_OK [simp]: "OK x ⊔⇘sup f⇙ OK y = OK (x ⊔⇩f y)"
by (simp add: plussub_def sup_def lift2_def)
lemma Err_sup_eq_OK_conv [iff]:
"(sup f ex ey = OK z) = (∃x y. ex = OK x ∧ ey = OK y ∧ f x y = z)"
apply (unfold sup_def lift2_def plussub_def)
apply (rule iffI)
apply (simp split: err.split_asm)
apply clarify
apply simp
done
lemma Err_sup_eq_Err [iff]: "(sup f ex ey = Err) = (ex=Err ∨ ey=Err)"
apply (unfold sup_def lift2_def plussub_def)
apply (simp split: err.split)
done
subsection ‹semilat (err A) (le r) f›
lemma semilat_le_err_Err_plus [simp]:
"⟦ x∈ err A; semilat(err A, le r, f) ⟧ ⟹ Err ⊔⇩f x = Err"
by (blast intro: Semilat.le_iff_plus_unchanged [THEN iffD1, OF Semilat.intro]
Semilat.le_iff_plus_unchanged2 [THEN iffD1, OF Semilat.intro])
lemma semilat_le_err_plus_Err [simp]:
"⟦ x∈ err A; semilat(err A, le r, f) ⟧ ⟹ x ⊔⇩f Err = Err"
by (blast intro: Semilat.le_iff_plus_unchanged [THEN iffD1, OF Semilat.intro]
Semilat.le_iff_plus_unchanged2 [THEN iffD1, OF Semilat.intro])
lemma semilat_le_err_OK1:
"⟦ x∈A; y∈A; semilat(err A, le r, f); OK x ⊔⇩f OK y = OK z ⟧
⟹ x ⊑⇩r z"
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst)
apply (simp add: Semilat.ub1 [OF Semilat.intro])
done
lemma semilat_le_err_OK2:
"⟦ x∈A; y∈A; semilat(err A, le r, f); OK x ⊔⇩f OK y = OK z ⟧
⟹ y ⊑⇩r z"
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst)
apply (simp add: Semilat.ub2 [OF Semilat.intro])
done
lemma eq_order_le:
"⟦ x=y; order r ⟧ ⟹ x ⊑⇩r y"
apply (unfold order_def)
apply blast
done
lemma OK_plus_OK_eq_Err_conv [simp]:
assumes "x∈A" "y∈A" "semilat(err A, le r, fe)"
shows "(OK x ⊔⇘fe⇙ OK y = Err) = (¬(∃z∈A. x ⊑⇩r z ∧ y ⊑⇩r z))"
proof -
have plus_le_conv3: "⋀A x y z f r.
⟦ semilat (A,r,f); x ⊔⇩f y ⊑⇩r z; x∈A; y∈A; z∈A ⟧
⟹ x ⊑⇩r z ∧ y ⊑⇩r z"
by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1])
from assms show ?thesis
apply (rule_tac iffI)
apply clarify
apply (drule OK_le_err_OK [THEN iffD2])
apply (drule OK_le_err_OK [THEN iffD2])
apply (drule Semilat.lub[OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
apply assumption
apply assumption
apply simp
apply simp
apply simp
apply simp
apply (case_tac "OK x ⊔⇘fe⇙ OK y")
apply assumption
apply (rename_tac z)
apply (subgoal_tac "OK z∈ err A")
apply (drule eq_order_le)
apply (erule Semilat.orderI [OF Semilat.intro])
apply (blast dest: plus_le_conv3)
apply (erule subst)
apply (blast intro: Semilat.closedI [OF Semilat.intro] closedD)
done
qed
subsection ‹semilat (err(Union AS))›
lemma all_bex_swap_lemma [iff]:
"(∀x. (∃y∈A. x = f y) ⟶ P x) = (∀y∈A. P(f y))"
by blast
lemma closed_err_Union_lift2I:
"⟦ ∀A∈AS. closed (err A) (lift2 f); AS ≠ {};
∀A∈AS.∀B∈AS. A≠B ⟶ (∀a∈A.∀b∈B. a ⊔⇩f b = Err) ⟧
⟹ closed (err(Union AS)) (lift2 f)"
apply (unfold closed_def err_def')
apply simp
apply clarify
apply simp
apply fast
done
text ‹
If @{term "AS = {}"} the thm collapses to
@{prop "order r ∧ closed {Err} f ∧ Err ⊔⇩f Err = Err"}
which may not hold
›
lemma err_semilat_UnionI:
"⟦ ∀A∈AS. err_semilat(A, r, f); AS ≠ {};
∀A∈AS.∀B∈AS. A≠B ⟶ (∀a∈A.∀b∈B. ¬a ⊑⇩r b ∧ a ⊔⇩f b = Err) ⟧
⟹ err_semilat(Union AS, r, f)"
apply (unfold semilat_def sl_def)
apply (simp add: closed_err_Union_lift2I)
apply (rule conjI)
apply blast
apply (simp add: err_def')
apply (rule conjI)
apply clarify
apply (rename_tac A a u B b)
apply (case_tac "A = B")
apply simp
apply simp
apply (rule conjI)
apply clarify
apply (rename_tac A a u B b)
apply (case_tac "A = B")
apply simp
apply simp
apply clarify
apply (rename_tac A ya yb B yd z C c a b)
apply (case_tac "A = B")
apply (case_tac "A = C")
apply simp
apply simp
apply (case_tac "B = C")
apply simp
apply simp
done
end
Theory Opt
section ‹More about Options›
theory Opt
imports
Err
begin
definition le :: "'a ord ⇒ 'a option ord"
where
"le r o⇩1 o⇩2 =
(case o⇩2 of None ⇒ o⇩1=None | Some y ⇒ (case o⇩1 of None ⇒ True | Some x ⇒ x ⊑⇩r y))"
definition opt :: "'a set ⇒ 'a option set"
where
"opt A = insert None {Some y |y. y ∈ A}"
definition sup :: "'a ebinop ⇒ 'a option ebinop"
where
"sup f o⇩1 o⇩2 =
(case o⇩1 of None ⇒ OK o⇩2
| Some x ⇒ (case o⇩2 of None ⇒ OK o⇩1
| Some y ⇒ (case f x y of Err ⇒ Err | OK z ⇒ OK (Some z))))"
definition esl :: "'a esl ⇒ 'a option esl"
where
"esl = (λ(A,r,f). (opt A, le r, sup f))"
lemma unfold_le_opt:
"o⇩1 ⊑⇘le r⇙ o⇩2 =
(case o⇩2 of None ⇒ o⇩1=None |
Some y ⇒ (case o⇩1 of None ⇒ True | Some x ⇒ x ⊑⇩r y))"
apply (unfold lesub_def le_def)
apply (rule refl)
done
lemma le_opt_refl: "order r ⟹ x ⊑⇘le r⇙ x"
by (simp add: unfold_le_opt split: option.split)
lemma le_opt_trans [rule_format]:
"order r ⟹ x ⊑⇘le r⇙ y ⟶ y ⊑⇘le r⇙ z ⟶ x ⊑⇘le r⇙ z"
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_trans)
done
lemma le_opt_antisym [rule_format]:
"order r ⟹ x ⊑⇘le r⇙ y ⟶ y ⊑⇘le r⇙ x ⟶ x=y"
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_antisym)
done
lemma order_le_opt [intro!,simp]: "order r ⟹ order(le r)"
apply (subst order_def)
apply (blast intro: le_opt_refl le_opt_trans le_opt_antisym)
done
lemma None_bot [iff]: "None ⊑⇘le r⇙ ox"
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done
lemma Some_le [iff]: "(Some x ⊑⇘le r⇙ z) = (∃y. z = Some y ∧ x ⊑⇩r y)"
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done
lemma le_None [iff]: "(x ⊑⇘le r⇙ None) = (x = None)"
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done
lemma OK_None_bot [iff]: "OK None ⊑⇘Err.le (le r)⇙ x"
by (simp add: lesub_def Err.le_def le_def split: option.split err.split)
lemma sup_None1 [iff]: "x ⊔⇘sup f⇙ None = OK x"
by (simp add: plussub_def sup_def split: option.split)
lemma sup_None2 [iff]: "None ⊔⇘sup f⇙ x = OK x"
by (simp add: plussub_def sup_def split: option.split)
lemma None_in_opt [iff]: "None ∈ opt A"
by (simp add: opt_def)
lemma Some_in_opt [iff]: "(Some x ∈ opt A) = (x ∈ A)"
by (unfold opt_def) auto
lemma semilat_opt [intro, simp]:
"err_semilat L ⟹ err_semilat (Opt.esl L)"
proof -
assume s: "err_semilat L"
obtain A r f where [simp]: "L = (A,r,f)" by (cases L)
let ?A0 = "err A" and ?r0 = "Err.le r" and ?f0 = "lift2 f"
from s obtain
ord: "order ?r0" and
clo: "closed ?A0 ?f0" and
ub1: "∀x∈?A0. ∀y∈?A0. x ⊑⇘?r0⇙ x ⊔⇘?f0⇙ y" and
ub2: "∀x∈?A0. ∀y∈?A0. y ⊑⇘?r0⇙ x ⊔⇘?f0⇙ y" and
lub: "∀x∈?A0. ∀y∈?A0. ∀z∈?A0. x ⊑⇘?r0⇙ z ∧ y ⊑⇘?r0⇙ z ⟶ x ⊔⇘?f0⇙ y ⊑⇘?r0⇙ z"
by (unfold semilat_def sl_def) simp
let ?A = "err (opt A)" and ?r = "Err.le (Opt.le r)" and ?f = "lift2 (Opt.sup f)"
from ord have "order ?r" by simp
moreover
have "closed ?A ?f"
proof (unfold closed_def, intro strip)
fix x y assume x: "x ∈ ?A" and y: "y ∈ ?A"
{ fix a b assume ab: "x = OK a" "y = OK b"
with x have a: "⋀c. a = Some c ⟹ c ∈ A" by (clarsimp simp add: opt_def)
from ab y have b: "⋀d. b = Some d ⟹ d ∈ A" by (clarsimp simp add: opt_def)
{ fix c d assume "a = Some c" "b = Some d"
with ab x y have "c ∈ A & d ∈ A" by (simp add: err_def opt_def Bex_def)
with clo have "f c d ∈ err A"
by (simp add: closed_def plussub_def err_def' lift2_def)
moreover fix z assume "f c d = OK z"
ultimately have "z ∈ A" by simp
} note f_closed = this
have "sup f a b ∈ ?A"
proof (cases a)
case None thus ?thesis
by (simp add: sup_def opt_def) (cases b, simp, simp add: b Bex_def)
next
case Some thus ?thesis
by (auto simp add: sup_def opt_def Bex_def a b f_closed split: err.split option.split)
qed
}
thus "x ⊔⇘?f⇙ y ∈ ?A" by (simp add: plussub_def lift2_def split: err.split)
qed
moreover
{ fix a b c assume "a ∈ opt A" and "b ∈ opt A" and "a ⊔⇘sup f⇙ b = OK c"
moreover from ord have "order r" by simp
moreover
{ fix x y z assume "x ∈ A" and "y ∈ A"
hence "OK x ∈ err A ∧ OK y ∈ err A" by simp
with ub1 ub2
have "(OK x) ⊑⇘Err.le r⇙ (OK x) ⊔⇘lift2 f⇙ (OK y) ∧
(OK y) ⊑⇘Err.le r⇙ (OK x) ⊔⇘lift2 f⇙ (OK y)"
by blast
moreover assume "x ⊔⇩f y = OK z"
ultimately have "x ⊑⇩r z ∧ y ⊑⇩r z"
by (auto simp add: plussub_def lift2_def Err.le_def lesub_def)
}
ultimately have "a ⊑⇘le r⇙ c ∧ b ⊑⇘le r⇙ c"
by (auto simp add: sup_def le_def lesub_def plussub_def
dest: order_refl split: option.splits err.splits)
}
hence "(∀x∈?A. ∀y∈?A. x ⊑⇘?r⇙ x ⊔⇘?f⇙ y) ∧ (∀x∈?A. ∀y∈?A. y ⊑⇘?r⇙ x ⊔⇘?f⇙ y)"
by (auto simp add: lesub_def plussub_def Err.le_def lift2_def split: err.split)
moreover
have "∀x∈?A. ∀y∈?A. ∀z∈?A. x ⊑⇘?r⇙ z ∧ y ⊑⇘?r⇙ z ⟶ x ⊔⇘?f⇙ y ⊑⇘?r⇙ z"
proof (intro strip, elim conjE)
fix x y z
assume xyz: "x ∈ ?A" "y ∈ ?A" "z ∈ ?A"
assume xz: "x ⊑⇘?r⇙ z" and yz: "y ⊑⇘?r⇙ z"
{ fix a b c assume ok: "x = OK a" "y = OK b" "z = OK c"
{ fix d e g assume some: "a = Some d" "b = Some e" "c = Some g"
with ok xyz obtain "OK d:err A" "OK e:err A" "OK g:err A" by simp
with lub
have "⟦ OK d ⊑⇘Err.le r⇙ OK g; OK e ⊑⇘Err.le r⇙ OK g ⟧ ⟹ OK d ⊔⇘lift2 f⇙ OK e ⊑⇘Err.le r⇙ OK g"
by blast
hence "⟦ d ⊑⇩r g; e ⊑⇩r g ⟧ ⟹ ∃y. d ⊔⇩f e = OK y ∧ y ⊑⇩r g" by simp
with ok some xyz xz yz have "x ⊔⇘?f⇙ y ⊑⇘?r⇙ z"
by (auto simp add: sup_def le_def lesub_def lift2_def plussub_def Err.le_def)
} note this [intro!]
from ok xyz xz yz have "x ⊔⇘?f⇙ y ⊑⇘?r⇙ z"
by - (cases a, simp, cases b, simp, cases c, simp, blast)
}
with xyz xz yz show "x ⊔⇘?f⇙ y ⊑⇘?r⇙ z"
by - (cases x, simp, cases y, simp, cases z, simp+)
qed
ultimately show "err_semilat (Opt.esl L)"
by (unfold semilat_def esl_def sl_def) simp
qed
lemma top_le_opt_Some [iff]: "top (le r) (Some T) = top r T"
apply (unfold top_def)
apply (rule iffI)
apply blast
apply (rule allI)
apply (case_tac "x")
apply simp+
done
lemma Top_le_conv: "⟦ order r; top r T ⟧ ⟹ (T ⊑⇩r x) = (x = T)"
apply (unfold top_def)
apply (blast intro: order_antisym)
done
lemma acc_le_optI [intro!]: "acc A r ⟹ acc (opt A) (le r)"
apply (unfold acc_def lesub_def le_def lesssub_def)
apply (simp add: wf_eq_minimal split: option.split)
apply clarify
apply (case_tac "∃a. Some a ∈ Q")
apply (erule_tac x = "{a . Some a ∈ Q}" in allE)
apply blast
apply (case_tac "x")
apply blast
apply blast
done
lemma map_option_in_optionI:
"⟦ ox ∈ opt S; ∀x∈S. ox = Some x ⟶ f x ∈ S ⟧
⟹ map_option f ox ∈ opt S"
apply (unfold map_option_case)
apply (simp split: option.split)
apply blast
done
end
Theory Product
section ‹Products as Semilattices›
theory Product
imports Err
begin
definition le :: "'a ord ⇒ 'b ord ⇒ ('a × 'b) ord"
where
"le r⇩A r⇩B = (λ(a⇩1,b⇩1) (a⇩2,b⇩2). a⇩1 ⊑⇘r⇩A⇙ a⇩2 ∧ b⇩1 ⊑⇘r⇩B⇙ b⇩2)"
definition sup :: "'a ebinop ⇒ 'b ebinop ⇒ ('a × 'b) ebinop"
where
"sup f g = (λ(a⇩1,b⇩1)(a⇩2,b⇩2). Err.sup Pair (a⇩1 ⊔⇩f a⇩2) (b⇩1 ⊔⇩g b⇩2))"
definition esl :: "'a esl ⇒ 'b esl ⇒ ('a × 'b ) esl"
where
"esl = (λ(A,r⇩A,f⇩A) (B,r⇩B,f⇩B). (A × B, le r⇩A r⇩B, sup f⇩A f⇩B))"
abbreviation
lesubprod :: "'a × 'b ⇒ ('a ⇒ 'a ⇒ bool) ⇒ ('b ⇒ 'b ⇒ bool) ⇒ 'a × 'b ⇒ bool"
("(_ /⊑'(_,_') _)" [50, 0, 0, 51] 50) where
"p ⊑(rA,rB) q == p ⊑⇘Product.le rA rB⇙ q"
notation
lesubprod ("(_ /<='(_,_') _)" [50, 0, 0, 51] 50)
lemma unfold_lesub_prod: "x ⊑(r⇩A,r⇩B) y = le r⇩A r⇩B x y"
by (simp add: lesub_def)
lemma le_prod_Pair_conv [iff]: "((a⇩1,b⇩1) ⊑(r⇩A,r⇩B) (a⇩2,b⇩2)) = (a⇩1 ⊑⇘r⇩A⇙ a⇩2 & b⇩1 ⊑⇘r⇩B⇙ b⇩2)"
by (simp add: lesub_def le_def)
lemma less_prod_Pair_conv:
"((a⇩1,b⇩1) ⊏⇘Product.le r⇩A r⇩B⇙ (a⇩2,b⇩2)) =
(a⇩1 ⊏⇘r⇩A⇙ a⇩2 & b⇩1 ⊑⇘r⇩B⇙ b⇩2 | a⇩1 ⊑⇘r⇩A⇙ a⇩2 & b⇩1 ⊏⇘r⇩B⇙ b⇩2)"
apply (unfold lesssub_def)
apply simp
apply blast
done
lemma order_le_prod [iff]: "order(Product.le r⇩A r⇩B) = (order r⇩A & order r⇩B)"
apply (unfold order_def)
apply simp
apply safe
apply blast+
done
lemma acc_le_prodI [intro!]:
"⟦ acc A r⇩A; acc B r⇩B ⟧ ⟹ acc (A × B) (Product.le r⇩A r⇩B)"
apply (unfold acc_def)
apply (rule wf_subset)
apply (erule wf_lex_prod)
apply assumption
apply (auto simp add: lesssub_def less_prod_Pair_conv lex_prod_def)
done
lemma closed_lift2_sup:
"⟦ closed (err A) (lift2 f); closed (err B) (lift2 g) ⟧ ⟹
closed (err(A×B)) (lift2(sup f g))"
apply (unfold closed_def plussub_def lift2_def err_def' sup_def)
apply (simp split: err.split)
apply blast
done
lemma unfold_plussub_lift2: "e⇩1 ⊔⇘lift2 f⇙ e⇩2 = lift2 f e⇩1 e⇩2"
by (simp add: plussub_def)
lemma plus_eq_Err_conv [simp]:
assumes "x∈A" "y∈A" "semilat(err A, Err.le r, lift2 f)"
shows "(x ⊔⇩f y = Err) = (¬(∃z∈A. x ⊑⇩r z ∧ y ⊑⇩r z))"
proof -
have plus_le_conv2:
"⋀r f z. ⟦ z ∈ err A; semilat (err A, r, f); OK x ∈ err A; OK y ∈ err A;
OK x ⊔⇩f OK y ⊑⇩r z⟧ ⟹ OK x ⊑⇩r z ∧ OK y ⊑⇩r z"
by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1])
from assms show ?thesis
apply (rule_tac iffI)
apply clarify
apply (drule OK_le_err_OK [THEN iffD2])
apply (drule OK_le_err_OK [THEN iffD2])
apply (drule Semilat.lub[OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
apply assumption
apply assumption
apply simp
apply simp
apply simp
apply simp
apply (case_tac "x ⊔⇩f y")
apply assumption
apply (rename_tac "z")
apply (subgoal_tac "OK z: err A")
apply (frule plus_le_conv2)
apply assumption
apply simp
apply blast
apply simp
apply (blast dest: Semilat.orderI [OF Semilat.intro] order_refl)
apply blast
apply (erule subst)
apply (unfold semilat_def err_def' closed_def)
apply simp
done
qed
lemma err_semilat_Product_esl:
"⋀L⇩1 L⇩2. ⟦ err_semilat L⇩1; err_semilat L⇩2 ⟧ ⟹ err_semilat(Product.esl L⇩1 L⇩2)"
apply (unfold esl_def Err.sl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (simp (no_asm) only: semilat_Def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (simp (no_asm) only: unfold_lesub_err Err.le_def unfold_plussub_lift2 sup_def)
apply (auto elim: semilat_le_err_OK1 semilat_le_err_OK2
simp add: lift2_def split: err.split)
apply (blast dest: Semilat.orderI [OF Semilat.intro])
apply (blast dest: Semilat.orderI [OF Semilat.intro])
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp
done
end
Theory Listn
section ‹Fixed Length Lists›
theory Listn
imports Err
begin
definition list :: "nat ⇒ 'a set ⇒ 'a list set"
where
"list n A = {xs. size xs = n ∧ set xs ⊆ A}"
definition le :: "'a ord ⇒ ('a list)ord"
where
"le r = list_all2 (λx y. x ⊑⇩r y)"
abbreviation
lesublist :: "'a list ⇒ 'a ord ⇒ 'a list ⇒ bool" ("(_ /[⊑⇘_⇙] _)" [50, 0, 51] 50) where
"x [⊑⇘r⇙] y == x <=_(Listn.le r) y"
abbreviation
lesssublist :: "'a list ⇒ 'a ord ⇒ 'a list ⇒ bool" ("(_ /[⊏⇘_⇙] _)" [50, 0, 51] 50) where
"x [⊏⇘r⇙] y == x <_(Listn.le r) y"
notation (ASCII)
lesublist ("(_ /[<=_] _)" [50, 0, 51] 50) and
lesssublist ("(_ /[<_] _)" [50, 0, 51] 50)
abbreviation (input)
lesublist2 :: "'a list ⇒ 'a ord ⇒ 'a list ⇒ bool" ("(_ /[⊑⇩_] _)" [50, 0, 51] 50) where
"x [⊑⇩r] y == x [⊑⇘r⇙] y"
abbreviation (input)
lesssublist2 :: "'a list ⇒ 'a ord ⇒ 'a list ⇒ bool" ("(_ /[⊏⇩_] _)" [50, 0, 51] 50) where
"x [⊏⇩r] y == x [⊏⇘r⇙] y"
abbreviation
plussublist :: "'a list ⇒ ('a ⇒ 'b ⇒ 'c) ⇒ 'b list ⇒ 'c list"
("(_ /[⊔⇘_⇙] _)" [65, 0, 66] 65) where
"x [⊔⇘f⇙] y == x ⊔⇘map2 f⇙ y"
notation
plussublist ("(_ /[+_] _)" [65, 0, 66] 65)
abbreviation (input)
plussublist2 :: "'a list ⇒ ('a ⇒ 'b ⇒ 'c) ⇒ 'b list ⇒ 'c list"
("(_ /[⊔⇩_] _)" [65, 0, 66] 65) where
"x [⊔⇩f] y == x [⊔⇘f⇙] y"
primrec coalesce :: "'a err list ⇒ 'a list err"
where
"coalesce [] = OK[]"
| "coalesce (ex#exs) = Err.sup (#) ex (coalesce exs)"
definition sl :: "nat ⇒ 'a sl ⇒ 'a list sl"
where
"sl n = (λ(A,r,f). (list n A, le r, map2 f))"
definition sup :: "('a ⇒ 'b ⇒ 'c err) ⇒ 'a list ⇒ 'b list ⇒ 'c list err"
where
"sup f = (λxs ys. if size xs = size ys then coalesce(xs [⊔⇘f⇙] ys) else Err)"
definition upto_esl :: "nat ⇒ 'a esl ⇒ 'a list esl"
where
"upto_esl m = (λ(A,r,f). (Union{list n A |n. n ≤ m}, le r, sup f))"
lemmas [simp] = set_update_subsetI
lemma unfold_lesub_list: "xs [⊑⇘r⇙] ys = Listn.le r xs ys"
by (simp add: lesub_def)
lemma Nil_le_conv [iff]: "([] [⊑⇘r⇙] ys) = (ys = [])"
apply (unfold lesub_def Listn.le_def)
apply simp
done
lemma Cons_notle_Nil [iff]: "¬ x#xs [⊑⇘r⇙] []"
apply (unfold lesub_def Listn.le_def)
apply simp
done
lemma Cons_le_Cons [iff]: "x#xs [⊑⇘r⇙] y#ys = (x ⊑⇩r y ∧ xs [⊑⇘r⇙] ys)"
by (simp add: lesub_def Listn.le_def)
lemma Cons_less_Conss [simp]:
"order r ⟹ x#xs [⊏⇩r] y#ys = (x ⊏⇩r y ∧ xs [⊑⇘r⇙] ys ∨ x = y ∧ xs [⊏⇩r] ys)"
apply (unfold lesssub_def)
apply blast
done
lemma list_update_le_cong:
"⟦ i<size xs; xs [⊑⇘r⇙] ys; x ⊑⇩r y ⟧ ⟹ xs[i:=x] [⊑⇘r⇙] ys[i:=y]"
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (simp add: list_all2_update_cong)
done
lemma le_listD: "⟦ xs [⊑⇘r⇙] ys; p < size xs ⟧ ⟹ xs!p ⊑⇩r ys!p"
by (simp add: Listn.le_def lesub_def list_all2_nthD)
lemma le_list_refl: "∀x. x ⊑⇩r x ⟹ xs [⊑⇘r⇙] xs"
apply (simp add: unfold_lesub_list lesub_def Listn.le_def list_all2_refl)
done
lemma le_list_trans: "⟦ order r; xs [⊑⇘r⇙] ys; ys [⊑⇘r⇙] zs ⟧ ⟹ xs [⊑⇘r⇙] zs"
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (rule list_all2_trans)
apply (erule order_trans)
apply assumption+
done
lemma le_list_antisym: "⟦ order r; xs [⊑⇘r⇙] ys; ys [⊑⇘r⇙] xs ⟧ ⟹ xs = ys"
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (rule list_all2_antisym)
apply (rule order_antisym)
apply assumption+
done
lemma order_listI [simp, intro!]: "order r ⟹ order(Listn.le r)"
apply (subst order_def)
apply (blast intro: le_list_refl le_list_trans le_list_antisym
dest: order_refl)
done
lemma lesub_list_impl_same_size [simp]: "xs [⊑⇘r⇙] ys ⟹ size ys = size xs"
apply (unfold Listn.le_def lesub_def)
apply (simp add: list_all2_lengthD)
done
lemma lesssub_lengthD: "xs [⊏⇩r] ys ⟹ size ys = size xs"
apply (unfold lesssub_def)
apply auto
done
lemma le_list_appendI: "a [⊑⇘r⇙] b ⟹ c [⊑⇘r⇙] d ⟹ a@c [⊑⇘r⇙] b@d"
apply (unfold Listn.le_def lesub_def)
apply (rule list_all2_appendI, assumption+)
done
lemma le_listI:
assumes "length a = length b"
assumes "⋀n. n < length a ⟹ a!n ⊑⇩r b!n"
shows "a [⊑⇘r⇙] b"
proof -
from assms have "list_all2 r a b"
by (simp add: list_all2_all_nthI lesub_def)
then show ?thesis by (simp add: Listn.le_def lesub_def)
qed
lemma listI: "⟦ size xs = n; set xs ⊆ A ⟧ ⟹ xs ∈ list n A"
apply (unfold list_def)
apply blast
done
lemma listE_length [simp]: "xs ∈ list n A ⟹ size xs = n"
apply (unfold list_def)
apply blast
done
lemma less_lengthI: "⟦ xs ∈ list n A; p < n ⟧ ⟹ p < size xs"
by simp
lemma listE_set [simp]: "xs ∈ list n A ⟹ set xs ⊆ A"
apply (unfold list_def)
apply blast
done
lemma list_0 [simp]: "list 0 A = {[]}"
apply (unfold list_def)
apply auto
done
lemma in_list_Suc_iff:
"(xs ∈ list (Suc n) A) = (∃y∈A. ∃ys ∈ list n A. xs = y#ys)"
apply (unfold list_def)
apply (case_tac "xs")
apply auto
done
lemma Cons_in_list_Suc [iff]:
"(x#xs ∈ list (Suc n) A) = (x∈A ∧ xs ∈ list n A)"
apply (simp add: in_list_Suc_iff)
done
lemma list_not_empty:
"∃a. a∈A ⟹ ∃xs. xs ∈ list n A"
apply (induct "n")
apply simp
apply (simp add: in_list_Suc_iff)
apply blast
done
lemma nth_in [rule_format, simp]:
"∀i n. size xs = n ⟶ set xs ⊆ A ⟶ i < n ⟶ (xs!i) ∈ A"
apply (induct "xs")
apply simp
apply (simp add: nth_Cons split: nat.split)
done
lemma listE_nth_in: "⟦ xs ∈ list n A; i < n ⟧ ⟹ xs!i ∈ A"
by auto
lemma listn_Cons_Suc [elim!]:
"l#xs ∈ list n A ⟹ (⋀n'. n = Suc n' ⟹ l ∈ A ⟹ xs ∈ list n' A ⟹ P) ⟹ P"
by (cases n) auto
lemma listn_appendE [elim!]:
"a@b ∈ list n A ⟹ (⋀n1 n2. n=n1+n2 ⟹ a ∈ list n1 A ⟹ b ∈ list n2 A ⟹ P) ⟹ P"
proof -
have "⋀n. a@b ∈ list n A ⟹ ∃n1 n2. n=n1+n2 ∧ a ∈ list n1 A ∧ b ∈ list n2 A"
(is "⋀n. ?list a n ⟹ ∃n1 n2. ?P a n n1 n2")
proof (induct a)
fix n assume "?list [] n"
hence "?P [] n 0 n" by simp
thus "∃n1 n2. ?P [] n n1 n2" by fast
next
fix n l ls
assume "?list (l#ls) n"
then obtain n' where n: "n = Suc n'" "l ∈ A" and n': "ls@b ∈ list n' A" by fastforce
assume "⋀n. ls @ b ∈ list n A ⟹ ∃n1 n2. n = n1 + n2 ∧ ls ∈ list n1 A ∧ b ∈ list n2 A"
from this and n' have "∃n1 n2. n' = n1 + n2 ∧ ls ∈ list n1 A ∧ b ∈ list n2 A" .
then obtain n1 n2 where "n' = n1 + n2" "ls ∈ list n1 A" "b ∈ list n2 A" by fast
with n have "?P (l#ls) n (n1+1) n2" by simp
thus "∃n1 n2. ?P (l#ls) n n1 n2" by fastforce
qed
moreover
assume "a@b ∈ list n A" "⋀n1 n2. n=n1+n2 ⟹ a ∈ list n1 A ⟹ b ∈ list n2 A ⟹ P"
ultimately
show ?thesis by blast
qed
lemma listt_update_in_list [simp, intro!]:
"⟦ xs ∈ list n A; x∈A ⟧ ⟹ xs[i := x] ∈ list n A"
apply (unfold list_def)
apply simp
done
lemma list_appendI [intro?]:
"⟦ a ∈ list n A; b ∈ list m A ⟧ ⟹ a @ b ∈ list (n+m) A"
by (unfold list_def) auto
lemma list_map [simp]: "(map f xs ∈ list (size xs) A) = (f ` set xs ⊆ A)"
by (unfold list_def) simp
lemma list_replicateI [intro]: "x ∈ A ⟹ replicate n x ∈ list n A"
by (induct n) auto
lemma plus_list_Nil [simp]: "[] [⊔⇘f⇙] xs = []"
apply (unfold plussub_def)
apply simp
done
lemma plus_list_Cons [simp]:
"(x#xs) [⊔⇘f⇙] ys = (case ys of [] ⇒ [] | y#ys ⇒ (x ⊔⇩f y)#(xs [⊔⇘f⇙] ys))"
by (simp add: plussub_def split: list.split)
lemma length_plus_list [rule_format, simp]:
"∀ys. size(xs [⊔⇘f⇙] ys) = min(size xs) (size ys)"
apply (induct xs)
apply simp
apply clarify
apply (simp (no_asm_simp) split: list.split)
done
lemma nth_plus_list [rule_format, simp]:
"∀xs ys i. size xs = n ⟶ size ys = n ⟶ i<n ⟶ (xs [⊔⇘f⇙] ys)!i = (xs!i) ⊔⇩f (ys!i)"
apply (induct n)
apply simp
apply clarify
apply (case_tac xs)
apply simp
apply (force simp add: nth_Cons split: list.split nat.split)
done
lemma (in Semilat) plus_list_ub1 [rule_format]:
"⟦ set xs ⊆ A; set ys ⊆ A; size xs = size ys ⟧
⟹ xs [⊑⇘r⇙] xs [⊔⇘f⇙] ys"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
lemma (in Semilat) plus_list_ub2:
"⟦set xs ⊆ A; set ys ⊆ A; size xs = size ys ⟧ ⟹ ys [⊑⇘r⇙] xs [⊔⇘f⇙] ys"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
lemma (in Semilat) plus_list_lub [rule_format]:
shows "∀xs ys zs. set xs ⊆ A ⟶ set ys ⊆ A ⟶ set zs ⊆ A
⟶ size xs = n ∧ size ys = n ⟶
xs [⊑⇘r⇙] zs ∧ ys [⊑⇘r⇙] zs ⟶ xs [⊔⇘f⇙] ys [⊑⇘r⇙] zs"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
lemma (in Semilat) list_update_incr [rule_format]:
"x∈A ⟹ set xs ⊆ A ⟶
(∀i. i<size xs ⟶ xs [⊑⇘r⇙] xs[i := x ⊔⇩f xs!i])"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
apply (induct xs)
apply simp
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp add: nth_Cons split: nat.split)
done
lemma acc_le_listI' [intro!]:
"⟦ order r; acc A r ⟧ ⟹ acc (⋃n. list n A) (Listn.le r)"
apply (unfold acc_def)
apply (subgoal_tac
"wf(UN n. {(ys,xs). xs ∈ list n A ∧ ys ∈ list n A ∧ xs <_(Listn.le r) ys})")
apply (erule wf_subset)
apply clarify
apply(rule UN_I)
prefer 2
apply clarify
apply(frule lesssub_lengthD)
apply fastforce
apply simp
apply (rule wf_UN)
prefer 2
apply (rename_tac m n)
apply (case_tac "m=n")
apply simp
apply (clarsimp intro!: equals0I)
apply (drule lesssub_lengthD)+
apply simp
apply (induct_tac n)
apply (simp add: lesssub_def cong: conj_cong)
apply (rename_tac k)
apply (simp add: wf_eq_minimal)
apply (simp (no_asm) add: in_list_Suc_iff cong: conj_cong)
apply clarify
apply (rename_tac M m)
apply (case_tac "∃x∈A. ∃xs∈list k A. x#xs ∈ M")
prefer 2
apply (erule thin_rl)
apply (erule thin_rl)
apply blast
apply (erule_tac x = "{a. a ∈ A ∧ (∃xs∈list k A. a#xs∈M)}" in allE)
apply (erule impE)
apply blast
apply (thin_tac "∃x∈A. ∃xs∈list k A. P x xs" for P)
apply clarify
apply (rename_tac maxA xs)
apply (erule_tac x = "{ys. ys ∈ list k A ∧ maxA#ys ∈ M}" in allE)
apply (erule impE)
apply blast
apply clarify
apply (thin_tac "m ∈ M")
apply (thin_tac "maxA#xs ∈ M")
apply (rule bexI)
prefer 2
apply assumption
apply clarify
apply simp
apply (erule disjE)
prefer 2
apply blast
by fastforce
lemma acc_le_listI [intro!]:
"⟦ order r; acc A r ⟧ ⟹ acc (list n A) (Listn.le r)"
apply(drule (1) acc_le_listI')
apply(erule thin_rl)
apply(unfold acc_def)
apply(erule wf_subset)
apply blast
done
lemma acc_le_list_uptoI [intro!]:
"⟦ order r; acc A r ⟧ ⟹ acc (⋃{list n A|n. n ≤ mxs}) (Listn.le r)"
apply(drule (1) acc_le_listI')
apply(erule thin_rl)
apply(unfold acc_def)
apply(erule wf_subset)
apply blast
done
lemma closed_listI:
"closed S f ⟹ closed (list n S) (map2 f)"
apply (unfold closed_def)
apply (induct n)
apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply simp
done
lemma Listn_sl_aux:
assumes "Semilat A r f" shows "semilat (Listn.sl n (A,r,f))"
proof -
interpret Semilat A r f by fact
show ?thesis
apply (unfold Listn.sl_def)
apply (simp (no_asm) only: semilat_Def split_conv)
apply (rule conjI)
apply simp
apply (rule conjI)
apply (simp only: closedI closed_listI)
apply (simp (no_asm) only: list_def)
apply (simp (no_asm_simp) add: plus_list_ub1 plus_list_ub2 plus_list_lub)
done
qed
lemma Listn_sl: "semilat L ⟹ semilat (Listn.sl n L)"
apply (cases L) apply simp
apply (drule Semilat.intro)
by (simp add: Listn_sl_aux split_tupled_all)
lemma coalesce_in_err_list [rule_format]:
"∀xes. xes ∈ list n (err A) ⟶ coalesce xes ∈ err(list n A)"
apply (induct n)
apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp (no_asm) add: plussub_def Err.sup_def lift2_def split: err.split)
apply force
done
lemma lem: "⋀x xs. x ⊔⇘(#)⇙ xs = x#xs"
by (simp add: plussub_def)
lemma coalesce_eq_OK1_D [rule_format]:
"semilat(err A, Err.le r, lift2 f) ⟹
∀xs. xs ∈ list n A ⟶ (∀ys. ys ∈ list n A ⟶
(∀zs. coalesce (xs [⊔⇘f⇙] ys) = OK zs ⟶ xs [⊑⇘r⇙] zs))"
apply (induct n)
apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK1)
done
lemma coalesce_eq_OK2_D [rule_format]:
"semilat(err A, Err.le r, lift2 f) ⟹
∀xs. xs ∈ list n A ⟶ (∀ys. ys ∈ list n A ⟶
(∀zs. coalesce (xs [⊔⇘f⇙] ys) = OK zs ⟶ ys [⊑⇘r⇙] zs))"
apply (induct n)
apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK2)
done
lemma lift2_le_ub:
"⟦ semilat(err A, Err.le r, lift2 f); x∈A; y∈A; x ⊔⇩f y = OK z;
u∈A; x ⊑⇩r u; y ⊑⇩r u ⟧ ⟹ z ⊑⇩r u"
apply (unfold semilat_Def plussub_def err_def')
apply (simp add: lift2_def)
apply clarify
apply (rotate_tac -3)
apply (erule thin_rl)
apply (erule thin_rl)
apply force
done
lemma coalesce_eq_OK_ub_D [rule_format]:
"semilat(err A, Err.le r, lift2 f) ⟹
∀xs. xs ∈ list n A ⟶ (∀ys. ys ∈ list n A ⟶
(∀zs us. coalesce (xs [⊔⇘f⇙] ys) = OK zs ∧ xs [⊑⇘r⇙] us ∧ ys [⊑⇘r⇙] us
∧ us ∈ list n A ⟶ zs [⊑⇘r⇙] us))"
apply (induct n)
apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp (no_asm_use) split: err.split_asm add: lem Err.sup_def lift2_def)
apply clarify
apply (rule conjI)
apply (blast intro: lift2_le_ub)
apply blast
done
lemma lift2_eq_ErrD:
"⟦ x ⊔⇩f y = Err; semilat(err A, Err.le r, lift2 f); x∈A; y∈A ⟧
⟹ ¬(∃u∈A. x ⊑⇩r u ∧ y ⊑⇩r u)"
by (simp add: OK_plus_OK_eq_Err_conv [THEN iffD1])
lemma coalesce_eq_Err_D [rule_format]:
"⟦ semilat(err A, Err.le r, lift2 f) ⟧
⟹ ∀xs. xs ∈ list n A ⟶ (∀ys. ys ∈ list n A ⟶
coalesce (xs [⊔⇘f⇙] ys) = Err ⟶
¬(∃zs ∈ list n A. xs [⊑⇘r⇙] zs ∧ ys [⊑⇘r⇙] zs))"
apply (induct n)
apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (blast dest: lift2_eq_ErrD)
done
lemma closed_err_lift2_conv:
"closed (err A) (lift2 f) = (∀x∈A. ∀y∈A. x ⊔⇩f y ∈ err A)"
apply (unfold closed_def)
apply (simp add: err_def')
done
lemma closed_map2_list [rule_format]:
"closed (err A) (lift2 f) ⟹
∀xs. xs ∈ list n A ⟶ (∀ys. ys ∈ list n A ⟶
map2 f xs ys ∈ list n (err A))"
apply (induct n)
apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp add: plussub_def closed_err_lift2_conv)
done
lemma closed_lift2_sup:
"closed (err A) (lift2 f) ⟹
closed (err (list n A)) (lift2 (sup f))"
by (fastforce simp add: closed_def plussub_def sup_def lift2_def
coalesce_in_err_list closed_map2_list
split: err.split)
lemma err_semilat_sup:
"err_semilat (A,r,f) ⟹
err_semilat (list n A, Listn.le r, sup f)"
apply (unfold Err.sl_def)
apply (simp only: split_conv)
apply (simp (no_asm) only: semilat_Def plussub_def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (rule conjI)
apply (drule Semilat.orderI [OF Semilat.intro])
apply simp
apply (simp (no_asm) only: unfold_lesub_err Err.le_def err_def' sup_def lift2_def)
apply (simp (no_asm_simp) add: coalesce_eq_OK1_D coalesce_eq_OK2_D split: err.split)
apply (blast intro: coalesce_eq_OK_ub_D dest: coalesce_eq_Err_D)
done
lemma err_semilat_upto_esl:
"⋀L. err_semilat L ⟹ err_semilat(upto_esl m L)"
apply (unfold Listn.upto_esl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (fastforce intro!: err_semilat_UnionI err_semilat_sup
dest: lesub_list_impl_same_size
simp add: plussub_def Listn.sup_def)
done
end
Theory Typing_Framework
section ‹Typing and Dataflow Analysis Framework›
theory Typing_Framework
imports
Semilattices
begin
text ‹
The relationship between dataflow analysis and a welltyped-instruction predicate.
›
type_synonym
's step_type = "nat ⇒ 's ⇒ (nat × 's) list"
definition stable :: "'s ord ⇒ 's step_type ⇒ 's list ⇒ nat ⇒ bool"
where
"stable r step τs p ⟷ (∀(q,τ) ∈ set (step p (τs!p)). τ ⊑⇩r τs!q)"
definition stables :: "'s ord ⇒ 's step_type ⇒ 's list ⇒ bool"
where
"stables r step τs ⟷ (∀p < size τs. stable r step τs p)"
definition wt_step :: "'s ord ⇒ 's ⇒ 's step_type ⇒ 's list ⇒ bool"
where
"wt_step r T step τs ⟷ (∀p<size τs. τs!p ≠ T ∧ stable r step τs p)"
definition is_bcv :: "'s ord ⇒ 's ⇒ 's step_type ⇒ nat ⇒ 's set ⇒ ('s list ⇒ 's list) ⇒ bool"
where
"is_bcv r T step n A bcv ⟷ (∀τs⇩0 ∈ list n A.
(∀p<n. (bcv τs⇩0)!p ≠ T) = (∃τs ∈ list n A. τs⇩0 [⊑⇩r] τs ∧ wt_step r T step τs))"
end
Theory SemilatAlg
section ‹More on Semilattices›
theory SemilatAlg
imports Typing_Framework
begin
definition lesubstep_type :: "(nat × 's) set ⇒ 's ord ⇒ (nat × 's) set ⇒ bool"
("(_ /{⊑⇘_⇙} _)" [50, 0, 51] 50)
where "A {⊑⇘r⇙} B ≡ ∀(p,τ) ∈ A. ∃τ'. (p,τ') ∈ B ∧ τ ⊑⇩r τ'"
notation (ASCII)
lesubstep_type ("(_ /{<='__} _)" [50, 0, 51] 50)
primrec pluslussub :: "'a list ⇒ ('a ⇒ 'a ⇒ 'a) ⇒ 'a ⇒ 'a" ("(_ /⨆⇘_⇙ _)" [65, 0, 66] 65)
where
"pluslussub [] f y = y"
| "pluslussub (x#xs) f y = pluslussub xs f (x ⊔⇩f y)"
notation (ASCII)
pluslussub ("(_ /++'__ _)" [65, 1000, 66] 65)
definition bounded :: "'s step_type ⇒ nat ⇒ bool"
where
"bounded step n ⟷ (∀p<n. ∀τ. ∀(q,τ') ∈ set (step p τ). q<n)"
definition pres_type :: "'s step_type ⇒ nat ⇒ 's set ⇒ bool"
where
"pres_type step n A ⟷ (∀τ∈A. ∀p<n. ∀(q,τ') ∈ set (step p τ). τ' ∈ A)"
definition mono :: "'s ord ⇒ 's step_type ⇒ nat ⇒ 's set ⇒ bool"
where
"mono r step n A ⟷
(∀τ p τ'. τ ∈ A ∧ p<n ∧ τ ⊑⇩r τ' ⟶ set (step p τ) {⊑⇘r⇙} set (step p τ'))"
lemma [iff]: "{} {⊑⇘r⇙} B"
by (simp add: lesubstep_type_def)
lemma [iff]: "(A {⊑⇘r⇙} {}) = (A = {})"
by (cases "A={}") (auto simp add: lesubstep_type_def)
lemma lesubstep_union:
"⟦ A⇩1 {⊑⇘r⇙} B⇩1; A⇩2 {⊑⇘r⇙} B⇩2 ⟧ ⟹ A⇩1 ∪ A⇩2 {⊑⇘r⇙} B⇩1 ∪ B⇩2"
by (auto simp add: lesubstep_type_def)
lemma pres_typeD:
"⟦ pres_type step n A; s∈A; p<n; (q,s')∈set (step p s) ⟧ ⟹ s' ∈ A"
by (unfold pres_type_def, blast)
lemma monoD:
"⟦ mono r step n A; p < n; s∈A; s ⊑⇩r t ⟧ ⟹ set (step p s) {⊑⇘r⇙} set (step p t)"
by (unfold mono_def, blast)
lemma boundedD:
"⟦ bounded step n; p < n; (q,t) ∈ set (step p xs) ⟧ ⟹ q < n"
by (unfold bounded_def, blast)
lemma lesubstep_type_refl [simp, intro]:
"(⋀x. x ⊑⇩r x) ⟹ A {⊑⇘r⇙} A"
by (unfold lesubstep_type_def) auto
lemma lesub_step_typeD:
"A {⊑⇘r⇙} B ⟹ (x,y) ∈ A ⟹ ∃y'. (x, y') ∈ B ∧ y ⊑⇩r y'"
by (unfold lesubstep_type_def) blast
lemma list_update_le_listI [rule_format]:
"set xs ⊆ A ⟶ set ys ⊆ A ⟶ xs [⊑⇩r] ys ⟶ p < size xs ⟶
x ⊑⇩r ys!p ⟶ semilat(A,r,f) ⟶ x∈A ⟶
xs[p := x ⊔⇩f xs!p] [⊑⇩r] ys"
apply (simp only: Listn.le_def lesub_def semilat_def)
apply (simp add: list_all2_conv_all_nth nth_list_update)
done
lemma plusplus_closed: assumes "Semilat A r f" shows
"⋀y. ⟦ set x ⊆ A; y ∈ A⟧ ⟹ x ⨆⇘f⇙ y ∈ A"
proof (induct x)
interpret Semilat A r f by fact
show "⋀y. y ∈ A ⟹ [] ⨆⇘f⇙ y ∈ A" by simp
fix y x xs
assume y: "y ∈ A" and xxs: "set (x#xs) ⊆ A"
assume IH: "⋀y. ⟦ set xs ⊆ A; y ∈ A⟧ ⟹ xs ⨆⇘f⇙ y ∈ A"
from xxs obtain x: "x ∈ A" and xs: "set xs ⊆ A" by simp
from x y have "x ⊔⇘f⇙ y ∈ A" ..
with xs have "xs ⨆⇘f⇙ (x ⊔⇘f⇙ y) ∈ A" by (rule IH)
thus "x#xs ⨆⇘f⇙ y ∈ A" by simp
qed
lemma (in Semilat) pp_ub2:
"⋀y. ⟦ set x ⊆ A; y ∈ A⟧ ⟹ y ⊑⇘r⇙ x ⨆⇘f⇙ y"
proof (induct x)
from semilat show "⋀y. y ⊑⇘r⇙ [] ⨆⇘f⇙ y" by simp
fix y a l assume y: "y ∈ A" and "set (a#l) ⊆ A"
then obtain a: "a ∈ A" and x: "set l ⊆ A" by simp
assume "⋀y. ⟦set l ⊆ A; y ∈ A⟧ ⟹ y ⊑⇘r⇙ l ⨆⇘f⇙ y"
from this and x have IH: "⋀y. y ∈ A ⟹ y ⊑⇘r⇙ l ⨆⇘f⇙ y" .
from a y have "y ⊑⇘r⇙ a ⊔⇘f⇙ y" ..
also from a y have "a ⊔⇘f⇙ y ∈ A" ..
hence "(a ⊔⇘f⇙ y) ⊑⇘r⇙ l ⨆⇘f⇙ (a ⊔⇘f⇙ y)" by (rule IH)
finally have "y ⊑⇘r⇙ l ⨆⇘f⇙ (a ⊔⇘f⇙ y)" .
thus "y ⊑⇘r⇙ (a#l) ⨆⇘f⇙ y" by simp
qed
lemma (in Semilat) pp_ub1:
shows "⋀y. ⟦set ls ⊆ A; y ∈ A; x ∈ set ls⟧ ⟹ x ⊑⇘r⇙ ls ⨆⇘f⇙ y"
proof (induct ls)
show "⋀y. x ∈ set [] ⟹ x ⊑⇘r⇙ [] ⨆⇘f⇙ y" by simp
fix y s ls
assume "set (s#ls) ⊆ A"
then obtain s: "s ∈ A" and ls: "set ls ⊆ A" by simp
assume y: "y ∈ A"
assume "⋀y. ⟦set ls ⊆ A; y ∈ A; x ∈ set ls⟧ ⟹ x ⊑⇘r⇙ ls ⨆⇘f⇙ y"
from this and ls have IH: "⋀y. x ∈ set ls ⟹ y ∈ A ⟹ x ⊑⇘r⇙ ls ⨆⇘f⇙ y" .
assume "x ∈ set (s#ls)"
then obtain xls: "x = s ∨ x ∈ set ls" by simp
moreover {
assume xs: "x = s"
from s y have "s ⊑⇘r⇙ s ⊔⇘f⇙ y" ..
also from s y have "s ⊔⇘f⇙ y ∈ A" ..
with ls have "(s ⊔⇘f⇙ y) ⊑⇘r⇙ ls ⨆⇘f⇙ (s ⊔⇘f⇙ y)" by (rule pp_ub2)
finally have "s ⊑⇘r⇙ ls ⨆⇘f⇙ (s ⊔⇘f⇙ y)" .
with xs have "x ⊑⇘r⇙ ls ⨆⇘f⇙ (s ⊔⇘f⇙ y)" by simp
}
moreover {
assume "x ∈ set ls"
hence "⋀y. y ∈ A ⟹ x ⊑⇘r⇙ ls ⨆⇘f⇙ y" by (rule IH)
moreover from s y have "s ⊔⇘f⇙ y ∈ A" ..
ultimately have "x ⊑⇘r⇙ ls ⨆⇘f⇙ (s ⊔⇘f⇙ y)" .
}
ultimately
have "x ⊑⇘r⇙ ls ⨆⇘f⇙ (s ⊔⇘f⇙ y)" by blast
thus "x ⊑⇘r⇙ (s#ls) ⨆⇘f⇙ y" by simp
qed
lemma (in Semilat) pp_lub:
assumes z: "z ∈ A"
shows
"⋀y. y ∈ A ⟹ set xs ⊆ A ⟹ ∀x ∈ set xs. x ⊑⇘r⇙ z ⟹ y ⊑⇘r⇙ z ⟹ xs ⨆⇘f⇙ y ⊑⇘r⇙ z"
proof (induct xs)
fix y assume "y ⊑⇘r⇙ z" thus "[] ⨆⇘f⇙ y ⊑⇘r⇙ z" by simp
next
fix y l ls assume y: "y ∈ A" and "set (l#ls) ⊆ A"
then obtain l: "l ∈ A" and ls: "set ls ⊆ A" by auto
assume "∀x ∈ set (l#ls). x ⊑⇘r⇙ z"
then obtain lz: "l ⊑⇘r⇙ z" and lsz: "∀x ∈ set ls. x ⊑⇘r⇙ z" by auto
assume "y ⊑⇘r⇙ z" with lz have "l ⊔⇘f⇙ y ⊑⇘r⇙ z" using l y z ..
moreover
from l y have "l ⊔⇘f⇙ y ∈ A" ..
moreover
assume "⋀y. y ∈ A ⟹ set ls ⊆ A ⟹ ∀x ∈ set ls. x ⊑⇘r⇙ z ⟹ y ⊑⇘r⇙ z
⟹ ls ⨆⇘f⇙ y ⊑⇘r⇙ z"
ultimately
have "ls ⨆⇘f⇙ (l ⊔⇘f⇙ y) ⊑⇘r⇙ z" using ls lsz by -
thus "(l#ls) ⨆⇘f⇙ y ⊑⇘r⇙ z" by simp
qed
lemma ub1': assumes "Semilat A r f"
shows "⟦∀(p,s) ∈ set S. s ∈ A; y ∈ A; (a,b) ∈ set S⟧
⟹ b ⊑⇘r⇙ map snd [(p', t') ← S. p' = a] ⨆⇘f⇙ y"
proof -
interpret Semilat A r f by fact
let "b ⊑⇘r⇙ ?map ⨆⇘f⇙ y" = ?thesis
assume "y ∈ A"
moreover
assume "∀(p,s) ∈ set S. s ∈ A"
hence "set ?map ⊆ A" by auto
moreover
assume "(a,b) ∈ set S"
hence "b ∈ set ?map" by (induct S, auto)
ultimately
show ?thesis by - (rule pp_ub1)
qed
lemma plusplus_empty:
"∀s'. (q, s') ∈ set S ⟶ s' ⊔⇘f⇙ ss ! q = ss ! q ⟹
(map snd [(p', t') ← S. p' = q] ⨆⇘f⇙ ss ! q) = ss ! q"
apply (induct S)
apply auto
done
end
Theory Typing_Framework_err
section ‹Lifting the Typing Framework to err, app, and eff›
theory Typing_Framework_err
imports
Typing_Framework
SemilatAlg
begin
definition wt_err_step :: "'s ord ⇒ 's err step_type ⇒ 's err list ⇒ bool"
where
"wt_err_step r step τs ⟷ wt_step (Err.le r) Err step τs"
definition wt_app_eff :: "'s ord ⇒ (nat ⇒ 's ⇒ bool) ⇒ 's step_type ⇒ 's list ⇒ bool"
where
"wt_app_eff r app step τs ⟷
(∀p < size τs. app p (τs!p) ∧ (∀(q,τ) ∈ set (step p (τs!p)). τ <=_r τs!q))"
definition map_snd :: "('b ⇒ 'c) ⇒ ('a × 'b) list ⇒ ('a × 'c) list"
where
"map_snd f = map (λ(x,y). (x, f y))"
definition error :: "nat ⇒ (nat × 'a err) list"
where
"error n = map (λx. (x,Err)) [0..<n]"
definition err_step :: "nat ⇒ (nat ⇒ 's ⇒ bool) ⇒ 's step_type ⇒ 's err step_type"
where
"err_step n app step p t =
(case t of
Err ⇒ error n
| OK τ ⇒ if app p τ then map_snd OK (step p τ) else error n)"
definition app_mono :: "'s ord ⇒ (nat ⇒ 's ⇒ bool) ⇒ nat ⇒ 's set ⇒ bool"
where
"app_mono r app n A ⟷
(∀s p t. s ∈ A ∧ p < n ∧ s ⊑⇩r t ⟶ app p t ⟶ app p s)"
lemmas err_step_defs = err_step_def map_snd_def error_def
lemma bounded_err_stepD:
"⟦ bounded (err_step n app step) n;
p < n; app p a; (q,b) ∈ set (step p a) ⟧ ⟹ q < n"
apply (simp add: bounded_def err_step_def)
apply (erule allE, erule impE, assumption)
apply (erule_tac x = "OK a" in allE, drule bspec)
apply (simp add: map_snd_def)
apply fast
apply simp
done
lemma in_map_sndD: "(a,b) ∈ set (map_snd f xs) ⟹ ∃b'. (a,b') ∈ set xs"
apply (induct xs)
apply (auto simp add: map_snd_def)
done
lemma bounded_err_stepI:
"∀p. p < n ⟶ (∀s. ap p s ⟶ (∀(q,s') ∈ set (step p s). q < n))
⟹ bounded (err_step n ap step) n"
apply (clarsimp simp: bounded_def err_step_def split: err.splits)
apply (simp add: error_def image_def)
apply (blast dest: in_map_sndD)
done
lemma bounded_lift:
"bounded step n ⟹ bounded (err_step n app step) n"
apply (unfold bounded_def err_step_def error_def)
apply clarify
apply (erule allE, erule impE, assumption)
apply (case_tac τ)
apply (auto simp add: map_snd_def split: if_split_asm)
done
lemma le_list_map_OK [simp]:
"⋀b. (map OK a [⊑⇘Err.le r⇙] map OK b) = (a [⊑⇩r] b)"
apply (induct a)
apply simp
apply simp
apply (case_tac b)
apply simp
apply simp
done
lemma map_snd_lessI:
"set xs {⊑⇘r⇙} set ys ⟹ set (map_snd OK xs) {⊑⇘Err.le r⇙} set (map_snd OK ys)"
apply (induct xs)
apply (unfold lesubstep_type_def map_snd_def)
apply auto
done
lemma mono_lift:
"⟦ order r; app_mono r app n A; bounded (err_step n app step) n;
∀s p t. s ∈ A ∧ p < n ∧ s ⊑⇩r t ⟶ app p t ⟶ set (step p s) {⊑⇘r⇙} set (step p t) ⟧
⟹ mono (Err.le r) (err_step n app step) n (err A)"
apply (simp only: app_mono_def SemilatAlg.mono_def err_step_def)
apply clarify
apply (case_tac τ)
apply simp
apply simp
apply (case_tac τ')
apply simp
apply clarify
apply (simp add: lesubstep_type_def error_def)
apply clarify
apply (drule in_map_sndD)
apply clarify
apply (drule bounded_err_stepD, assumption+)
apply (rule exI [of _ Err])
apply simp
apply simp
apply (erule allE, erule allE, erule allE, erule impE)
apply (rule conjI, assumption)
apply (rule conjI, assumption)
apply assumption
apply (rule conjI)
apply clarify
apply (erule allE, erule allE, erule allE, erule impE)
apply (rule conjI, assumption)
apply (rule conjI, assumption)
apply assumption
apply (erule impE, assumption)
apply (rule map_snd_lessI, assumption)
apply clarify
apply (simp add: lesubstep_type_def error_def)
apply clarify
apply (drule in_map_sndD)
apply clarify
apply (drule bounded_err_stepD, assumption+)
apply (rule exI [of _ Err])
apply simp
done
lemma in_errorD: "(x,y) ∈ set (error n) ⟹ y = Err"
by (auto simp add: error_def)
lemma pres_type_lift:
"∀s∈A. ∀p. p < n ⟶ app p s ⟶ (∀(q, s')∈set (step p s). s' ∈ A)
⟹ pres_type (err_step n app step) n (err A)"
apply (unfold pres_type_def err_step_def)
apply clarify
apply (case_tac b)
apply simp
apply (case_tac τ)
apply simp
apply (drule in_errorD)
apply simp
apply (simp add: map_snd_def split: if_split_asm)
apply fast
apply (drule in_errorD)
apply simp
done
lemma wt_err_imp_wt_app_eff:
assumes wt: "wt_err_step r (err_step (size ts) app step) ts"
assumes b: "bounded (err_step (size ts) app step) (size ts)"
shows "wt_app_eff r app step (map ok_val ts)"
proof (unfold wt_app_eff_def, intro strip, rule conjI)
fix p assume "p < size (map ok_val ts)"
hence lp: "p < size ts" by simp
hence ts: "0 < size ts" by (cases p) auto
hence err: "(0,Err) ∈ set (error (size ts))" by (simp add: error_def)
from wt lp
have [intro?]: "⋀p. p < size ts ⟹ ts ! p ≠ Err"
by (unfold wt_err_step_def wt_step_def) simp
show app: "app p (map ok_val ts ! p)"
proof (rule ccontr)
from wt lp obtain s where
OKp: "ts ! p = OK s" and
less: "∀(q,t) ∈ set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
by (unfold wt_err_step_def wt_step_def stable_def)
(auto iff: not_Err_eq)
assume "¬ app p (map ok_val ts ! p)"
with OKp lp have "¬ app p s" by simp
with OKp have "err_step (size ts) app step p (ts!p) = error (size ts)"
by (simp add: err_step_def)
with err ts obtain q where
"(q,Err) ∈ set (err_step (size ts) app step p (ts!p))" and
q: "q < size ts" by auto
with less have "ts!q = Err" by auto
moreover from q have "ts!q ≠ Err" ..
ultimately show False by blast
qed
show "∀(q,t)∈set(step p (map ok_val ts ! p)). t ⊑⇩r map ok_val ts ! q"
proof clarify
fix q t assume q: "(q,t) ∈ set (step p (map ok_val ts ! p))"
from wt lp q
obtain s where
OKp: "ts ! p = OK s" and
less: "∀(q,t) ∈ set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
by (unfold wt_err_step_def wt_step_def stable_def)
(auto iff: not_Err_eq)
from b lp app q have lq: "q < size ts" by (rule bounded_err_stepD)
hence "ts!q ≠ Err" ..
then obtain s' where OKq: "ts ! q = OK s'" by (auto iff: not_Err_eq)
from lp lq OKp OKq app less q
show "t ⊑⇩r map ok_val ts ! q"
by (auto simp add: err_step_def map_snd_def)
qed
qed
lemma wt_app_eff_imp_wt_err:
assumes app_eff: "wt_app_eff r app step ts"
assumes bounded: "bounded (err_step (size ts) app step) (size ts)"
shows "wt_err_step r (err_step (size ts) app step) (map OK ts)"
proof (unfold wt_err_step_def wt_step_def, intro strip, rule conjI)
fix p assume "p < size (map OK ts)"
hence p: "p < size ts" by simp
thus "map OK ts ! p ≠ Err" by simp
{ fix q t
assume q: "(q,t) ∈ set (err_step (size ts) app step p (map OK ts ! p))"
with p app_eff obtain
"app p (ts ! p)" "∀(q,t) ∈ set (step p (ts!p)). t ⊑⇩r ts!q"
by (unfold wt_app_eff_def) blast
moreover
from q p bounded have "q < size ts"
by - (rule boundedD)
hence "map OK ts ! q = OK (ts!q)" by simp
moreover
have "p < size ts" by (rule p)
moreover note q
ultimately
have "t ⊑⇘Err.le r⇙ map OK ts ! q"
by (auto simp add: err_step_def map_snd_def)
}
thus "stable (Err.le r) (err_step (size ts) app step) (map OK ts) p"
by (unfold stable_def) blast
qed
end
Theory Kildall
section ‹Kildall's Algorithm \label{sec:Kildall}›
theory Kildall
imports SemilatAlg "../Basic/Auxiliary"
begin
locale Kildall_base =
fixes s_α :: "'w ⇒ nat set"
and s_empty :: "'w"
and s_is_empty :: "'w ⇒ bool"
and s_choose :: "'w ⇒ nat"
and s_remove :: "nat ⇒ 'w ⇒ 'w"
and s_insert :: "nat ⇒ 'w ⇒ 'w"
begin
primrec propa :: "'s binop ⇒ (nat × 's) list ⇒ 's list ⇒ 'w ⇒ 's list * 'w"
where
"propa f [] τs w = (τs,w)"
| "propa f (q'#qs) τs w = (let (q,τ) = q';
u = τ ⊔⇘f⇙ τs!q;
w' = (if u = τs!q then w else s_insert q w)
in propa f qs (τs[q := u]) w')"
definition iter :: "'s binop ⇒ 's step_type ⇒ 's list ⇒ 'w ⇒ 's list × 'w"
where
"iter f step τs w =
while (λ(τs,w). ¬ s_is_empty w)
(λ(τs,w). let p = s_choose w in propa f (step p (τs!p)) τs (s_remove p w))
(τs,w)"
definition unstables :: "'s ord ⇒ 's step_type ⇒ 's list ⇒ 'w"
where
"unstables r step τs = foldr s_insert (filter (λp. ¬stable r step τs p) [0..<size τs]) s_empty"
definition kildall :: "'s ord ⇒ 's binop ⇒ 's step_type ⇒ 's list ⇒ 's list"
where "kildall r f step τs ≡ fst(iter f step τs (unstables r step τs))"
primrec t_α :: "'s list × 'w ⇒ 's list × nat set"
where "t_α (τs, w) = (τs, s_α w)"
end
primrec merges :: "'s binop ⇒ (nat × 's) list ⇒ 's list ⇒ 's list"
where
"merges f [] τs = τs"
| "merges f (p'#ps) τs = (let (p,τ) = p' in merges f ps (τs[p := τ ⊔⇘f⇙ τs!p]))"
locale Kildall =
Kildall_base +
assumes empty_spec [simp]: "s_α s_empty = {}"
and is_empty_spec [simp]: "s_is_empty A ⟷ s_α A = {}"
and choose_spec: "s_α A ≠ {} ⟹ s_choose A ∈ s_α A"
and remove_spec [simp]: "s_α (s_remove n A) = s_α A - {n}"
and insert_spec [simp]: "s_α (s_insert n A) = insert n (s_α A)"
begin
lemma s_α_foldr_s_insert:
"s_α (foldr s_insert xs A) = foldr insert xs (s_α A)"
by(induct xs arbitrary: A) simp_all
lemma unstables_spec [simp]: "s_α (unstables r step τs) = {p. p < size τs ∧ ¬stable r step τs p}"
proof -
have "{p. p < size τs ∧ ¬stable r step τs p} = foldr insert (filter (λp. ¬stable r step τs p) [0..<size τs]) {}"
unfolding foldr_insert_conv_set by auto
thus ?thesis by(simp add: unstables_def s_α_foldr_s_insert)
qed
end
lemmas [simp] = Let_def Semilat.le_iff_plus_unchanged [OF Semilat.intro, symmetric]
lemma (in Semilat) nth_merges:
"⋀ss. ⟦p < length ss; ss ∈ list n A; ∀(p,t)∈set ps. p<n ∧ t∈A ⟧ ⟹
(merges f ps ss)!p = map snd [(p',t') ← ps. p'=p] ⨆⇘f⇙ ss!p"
(is "⋀ss. ⟦_; _; ?steptype ps⟧ ⟹ ?P ss ps")
proof (induct ps)
show "⋀ss. ?P ss []" by simp
fix ss p' ps'
assume ss: "ss ∈ list n A"
assume l: "p < length ss"
assume "?steptype (p'#ps')"
then obtain a b where
p': "p'=(a,b)" and ab: "a<n" "b∈A" and ps': "?steptype ps'"
by (cases p') auto
assume "⋀ss. p< length ss ⟹ ss ∈ list n A ⟹ ?steptype ps' ⟹ ?P ss ps'"
hence IH: "⋀ss. ss ∈ list n A ⟹ p < length ss ⟹ ?P ss ps'" using ps' by iprover
from ss ab
have "ss[a := b ⊔⇘f⇙ ss!a] ∈ list n A" by (simp add: closedD)
moreover
with l have "p < length (ss[a := b ⊔⇘f⇙ ss!a])" by simp
ultimately
have "?P (ss[a := b ⊔⇘f⇙ ss!a]) ps'" by (rule IH)
with p' l
show "?P ss (p'#ps')" by simp
qed
lemma length_merges [simp]:
"⋀ss. size(merges f ps ss) = size ss"
by (induct ps, auto)
lemma (in Semilat) merges_preserves_type_lemma:
shows "∀xs. xs ∈ list n A ⟶ (∀(p,x) ∈ set ps. p<n ∧ x∈A)
⟶ merges f ps xs ∈ list n A"
apply (insert closedI)
apply (unfold Semilat.closed_def)
apply (induct ps)
apply simp
apply clarsimp
done
lemma (in Semilat) merges_preserves_type [simp]:
"⟦ xs ∈ list n A; ∀(p,x) ∈ set ps. p<n ∧ x∈A ⟧
⟹ merges f ps xs ∈ list n A"
by (simp add: merges_preserves_type_lemma)
lemma (in Semilat) merges_incr_lemma:
"∀xs. xs ∈ list n A ⟶ (∀(p,x)∈set ps. p<size xs ∧ x ∈ A) ⟶ xs [⊑⇘r⇙] merges f ps xs"
apply (induct ps)
apply simp
apply simp
apply clarify
apply (rule order_trans)
apply simp
apply (erule list_update_incr)
apply simp
apply simp
apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
done
lemma (in Semilat) merges_incr:
"⟦ xs ∈ list n A; ∀(p,x)∈set ps. p<size xs ∧ x ∈ A ⟧
⟹ xs [⊑⇘r⇙] merges f ps xs"
by (simp add: merges_incr_lemma)
lemma (in Semilat) merges_same_conv [rule_format]:
"(∀xs. xs ∈ list n A ⟶ (∀(p,x)∈set ps. p<size xs ∧ x∈A) ⟶
(merges f ps xs = xs) = (∀(p,x)∈set ps. x ⊑⇘r⇙ xs!p))"
apply (induct_tac ps)
apply simp
apply clarsimp
apply (rename_tac p x ps xs)
apply (rule iffI)
apply (rule context_conjI)
apply (subgoal_tac "xs[p := x ⊔⇘f⇙ xs!p] [⊑⇘r⇙] xs")
apply (force dest!: le_listD simp add: nth_list_update)
apply (erule subst, rule merges_incr)
apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
apply clarify
apply (rule conjI)
apply simp
apply (blast dest: boundedD)
apply blast
apply clarify
apply (erule allE)
apply (erule impE)
apply assumption
apply (drule bspec)
apply assumption
apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
apply blast
apply clarify
apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
done
lemma (in Semilat) list_update_le_listI [rule_format]:
"set xs ⊆ A ⟶ set ys ⊆ A ⟶ xs [⊑⇘r⇙] ys ⟶ p < size xs ⟶
x ⊑⇘r⇙ ys!p ⟶ x∈A ⟶ xs[p := x ⊔⇘f⇙ xs!p] [⊑⇘r⇙] ys"
apply(insert semilat)
apply (simp only: Listn.le_def lesub_def semilat_def)
apply (simp add: list_all2_conv_all_nth nth_list_update)
done
lemma (in Semilat) merges_pres_le_ub:
assumes "set ts ⊆ A" "set ss ⊆ A"
"∀(p,t)∈set ps. t ⊑⇘r⇙ ts!p ∧ t ∈ A ∧ p < size ts" "ss [⊑⇘r⇙] ts"
shows "merges f ps ss [⊑⇘r⇙] ts"
proof -
{ fix t ts ps
have
"⋀qs. ⟦set ts ⊆ A; ∀(p,t)∈set ps. t ⊑⇘r⇙ ts!p ∧ t ∈ A ∧ p< size ts ⟧ ⟹
set qs ⊆ set ps ⟶
(∀ss. set ss ⊆ A ⟶ ss [⊑⇘r⇙] ts ⟶ merges f qs ss [⊑⇘r⇙] ts)"
apply (induct_tac qs)
apply simp
apply (simp (no_asm_simp))
apply clarify
apply simp
apply (erule allE, erule impE, erule_tac [2] mp)
apply (drule bspec, assumption)
apply (simp add: closedD)
apply (drule bspec, assumption)
apply (simp add: list_update_le_listI)
done
} note this [dest]
from assms show ?thesis by blast
qed
context Kildall begin
subsection ‹@{term propa}›
lemma decomp_propa:
"⋀ss w. (∀(q,t)∈set qs. q < size ss) ⟹
t_α (propa f qs ss w) =
(merges f qs ss, {q. ∃t.(q,t)∈set qs ∧ t ⊔⇘f⇙ ss!q ≠ ss!q} ∪ s_α w)"
apply (induct qs)
apply simp
apply (simp (no_asm))
apply clarify
apply simp
apply (rule conjI)
apply blast
apply (simp add: nth_list_update)
apply blast
done
end
lemma (in Semilat) stable_pres_lemma:
shows "⟦pres_type step n A; bounded step n;
ss ∈ list n A; p ∈ w; ∀q∈w. q < n;
∀q. q < n ⟶ q ∉ w ⟶ stable r step ss q; q < n;
∀s'. (q,s') ∈ set (step p (ss!p)) ⟶ s' ⊔⇘f⇙ ss!q = ss!q;
q ∉ w ∨ q = p ⟧
⟹ stable r step (merges f (step p (ss!p)) ss) q"
apply (unfold stable_def)
apply (subgoal_tac "∀s'. (q,s') ∈ set (step p (ss!p)) ⟶ s' : A")
prefer 2
apply clarify
apply (erule pres_typeD)
prefer 3 apply assumption
apply (rule listE_nth_in)
apply assumption
apply simp
apply simp
apply simp
apply clarify
apply (subst nth_merges)
apply simp
apply (blast dest: boundedD)
apply assumption
apply clarify
apply (rule conjI)
apply (blast dest: boundedD)
apply (erule pres_typeD)
prefer 3 apply assumption
apply simp
apply simp
apply(subgoal_tac "q < length ss")
prefer 2 apply simp
apply (frule nth_merges [of q _ _ "step p (ss!p)"])
apply assumption
apply clarify
apply (rule conjI)
apply (blast dest: boundedD)
apply (erule pres_typeD)
prefer 3 apply assumption
apply simp
apply simp
apply (drule_tac P = "λx. (a, b) ∈ set (step q x)" in subst)
apply assumption
apply (simp add: plusplus_empty)
apply (cases "q ∈ w")
apply simp
apply (rule ub1')
apply (rule Semilat.intro)
apply (rule semilat)
apply clarify
apply (rule pres_typeD)
apply assumption
prefer 3 apply assumption
apply (blast intro: listE_nth_in dest: boundedD)
apply (blast intro: pres_typeD dest: boundedD)
apply (blast intro: listE_nth_in dest: boundedD)
apply assumption
apply simp
apply (erule allE, erule impE, assumption, erule impE, assumption)
apply (rule order_trans)
apply simp
defer
apply (rule pp_ub2)
apply simp
apply clarify
apply simp
apply (rule pres_typeD)
apply assumption
prefer 3 apply assumption
apply (blast intro: listE_nth_in dest: boundedD)
apply (blast intro: pres_typeD dest: boundedD)
apply (blast intro: listE_nth_in dest: boundedD)
apply blast
done
lemma (in Semilat) merges_bounded_lemma:
"⟦ mono r step n A; bounded step n;
∀(p',s') ∈ set (step p (ss!p)). s' ∈ A; ss ∈ list n A; ts ∈ list n A; p < n;
ss [⊑⇩r] ts; ∀p. p < n ⟶ stable r step ts p ⟧
⟹ merges f (step p (ss!p)) ss [⊑⇩r] ts"
apply (unfold stable_def)
apply (rule merges_pres_le_ub)
apply simp
apply simp
prefer 2 apply assumption
apply clarsimp
apply (drule boundedD, assumption+)
apply (erule allE, erule impE, assumption)
apply (drule bspec, assumption)
apply simp
apply (drule monoD [of _ _ _ _ p "ss!p" "ts!p"])
apply assumption
apply simp
apply (simp add: le_listD)
apply (drule lesub_step_typeD, assumption)
apply clarify
apply (drule bspec, assumption)
apply simp
apply (blast intro: order_trans)
done
lemma termination_lemma: assumes "Semilat A r f"
shows "⟦ ss ∈ list n A; ∀(q,t)∈set qs. q<n ∧ t∈A; p∈w ⟧ ⟹
ss [⊏⇩r] merges f qs ss ∨
merges f qs ss = ss ∧ {q. ∃t. (q,t)∈set qs ∧ t ⊔⇘f⇙ ss!q ≠ ss!q} ∪ (w-{p}) ⊂ w"
(is "PROP ?P")
proof -
interpret Semilat A r f by fact
show "PROP ?P"
apply(insert semilat)
apply (unfold lesssub_def)
apply (simp (no_asm_simp) add: merges_incr)
apply (rule impI)
apply (rule merges_same_conv [THEN iffD1, elim_format])
apply assumption+
defer
apply (rule sym, assumption)
defer apply simp
apply (subgoal_tac "∀q t. ¬((q, t) ∈ set qs ∧ t ⊔⇘f⇙ ss ! q ≠ ss ! q)")
apply (blast intro!: psubsetI elim: equalityE)
apply clarsimp
apply (drule bspec, assumption)
apply (drule bspec, assumption)
apply clarsimp
done
qed
context Kildall_base begin
definition s_finite_psubset :: "('w * 'w) set"
where "s_finite_psubset == {(A,B). s_α A < s_α B & finite (s_α B)}"
lemma s_finite_psubset_inv_image:
"s_finite_psubset = inv_image finite_psubset s_α"
by(auto simp add: s_finite_psubset_def finite_psubset_def)
lemma wf_s_finite_psubset [simp]: "wf s_finite_psubset"
unfolding s_finite_psubset_inv_image by simp
end
context Kildall begin
subsection ‹@{term iter}›
lemma iter_properties[rule_format]: assumes "Semilat A r f"
shows "⟦ acc A r; pres_type step n A; mono r step n A;
bounded step n; ∀p∈s_α w0. p < n; ss0 ∈ list n A;
∀p<n. p ∉ s_α w0 ⟶ stable r step ss0 p ⟧ ⟹
t_α (iter f step ss0 w0) = (ss',w')
⟶
ss' ∈ list n A ∧ stables r step ss' ∧ ss0 [⊑⇩r] ss' ∧
(∀ts∈list n A. ss0 [⊑⇩r] ts ∧ stables r step ts ⟶ ss' [⊑⇩r] ts)"
(is "PROP ?P")
proof -
interpret Semilat A r f by fact
show "PROP ?P"
apply(insert semilat)
apply (unfold iter_def stables_def)
apply(unfold is_empty_spec)
apply (rule_tac P = "λ(ss,w).
ss ∈ list n A ∧ (∀p<n. p ∉ s_α w ⟶ stable r step ss p) ∧ ss0 [⊑⇩r] ss ∧
(∀ts∈list n A. ss0 [⊑⇩r] ts ∧ stables r step ts ⟶ ss [⊑⇩r] ts) ∧
(∀p∈ s_α w. p < n)" and
r = "{(ss',ss) . ss ∈ list n A ∧ ss' ∈ list n A ∧ ss [⊏⇩r] ss'} <*lex*> s_finite_psubset"
in while_rule)
apply (simp add:stables_def)
apply(simp add: stables_def split_paired_all)
apply(rename_tac ss w)
apply(subgoal_tac "s_choose w ∈ s_α w")
prefer 2 apply(erule choose_spec)
apply(subgoal_tac "∀(q,t) ∈ set (step (s_choose w) (ss ! (s_choose w))). q < length ss ∧ t ∈ A")
prefer 2
apply clarify
apply (rule conjI)
apply(clarsimp, blast dest!: boundedD)
apply (erule pres_typeD)
prefer 3
apply assumption
apply (erule listE_nth_in)
apply blast
apply blast
apply(subgoal_tac "(λ(ss, w).
ss ∈ list n A ∧
(∀p<n. p ∉ w ⟶ stable r step ss p) ∧
ss0 [⊑⇘r⇙] ss ∧
(∀ts∈list n A.
ss0 [⊑⇘r⇙] ts ∧ (∀p<n. stable r step ts p) ⟶ ss [⊑⇘r⇙] ts) ∧
(∀p∈w. p < n))
(t_α (propa f (step (s_choose w) (ss ! s_choose w)) ss
(s_remove (s_choose w) w)))")
apply(case_tac "propa f (step (s_choose w) (ss ! s_choose w)) ss (s_remove (s_choose w) w)")
apply(simp)
apply (subst decomp_propa)
apply blast
apply simp
apply (rule conjI)
apply (rule merges_preserves_type)
apply blast
apply clarify
apply (rule conjI)
apply(clarsimp, blast dest!: boundedD)
apply (erule pres_typeD)
prefer 3
apply assumption
apply (erule listE_nth_in)
apply blast
apply blast
apply (rule conjI)
apply clarify
apply (blast intro!: stable_pres_lemma)
apply (rule conjI)
apply (blast intro!: merges_incr intro: le_list_trans)
apply (rule conjI)
apply clarsimp
apply (blast intro!: merges_bounded_lemma)
apply (blast dest!: boundedD)
apply(clarsimp simp add: stables_def split_paired_all)
apply (rule wf_lex_prod)
apply (insert orderI [THEN acc_le_listI])
apply (simp only: acc_def lesssub_def)
apply (rule wf_s_finite_psubset)
apply(simp add: stables_def split_paired_all)
apply(rename_tac ss w)
apply(subgoal_tac "s_choose w ∈ s_α w")
prefer 2 apply (erule choose_spec)
apply(subgoal_tac "∀(q,t) ∈ set (step (s_choose w) (ss ! (s_choose w))). q < length ss ∧ t ∈ A")
prefer 2
apply clarify
apply (rule conjI)
apply(clarsimp, blast dest!: boundedD)
apply (erule pres_typeD)
prefer 3
apply assumption
apply (erule listE_nth_in)
apply blast
apply blast
apply(subgoal_tac "(t_α (propa f (step (s_choose w) (ss ! s_choose w)) ss
(s_remove (s_choose w) w)),
ss, s_α w)
∈ {(ss', ss). ss ∈ list n A ∧ ss' ∈ list n A ∧ ss [⊏⇘r⇙] ss'} <*lex*> finite_psubset")
prefer 2
apply (subst decomp_propa)
apply blast
apply clarify
apply (simp del: listE_length
add: lex_prod_def finite_psubset_def bounded_nat_set_is_finite)
apply(subgoal_tac "merges f (step (s_choose w) (ss ! s_choose w)) ss ∈ list n A")
apply simp
apply (rule termination_lemma)
apply (rule assms)
apply assumption+
apply clarsimp
apply(case_tac "propa f (step (s_choose w) (ss ! s_choose w)) ss
(s_remove (s_choose w) w)")
apply(simp add: s_finite_psubset_inv_image)
done
qed
lemma kildall_properties: assumes "Semilat A r f"
shows "⟦ acc A r; pres_type step n A; mono r step n A;
bounded step n; ss0 ∈ list n A ⟧ ⟹
kildall r f step ss0 ∈ list n A ∧
stables r step (kildall r f step ss0) ∧
ss0 [⊑⇩r] kildall r f step ss0 ∧
(∀ts∈list n A. ss0 [⊑⇩r] ts ∧ stables r step ts ⟶
kildall r f step ss0 [⊑⇩r] ts)"
(is "PROP ?P")
proof -
interpret Semilat A r f by fact
show "PROP ?P"
apply (unfold kildall_def)
apply(case_tac "iter f step ss0 (unstables r step ss0)")
apply(simp)
apply (rule iter_properties[where ?w0.0="unstables r step ss0"])
apply(rule assms)
apply (simp_all add: unstables_def stable_def s_α_foldr_s_insert foldr_insert_conv_set)
done
qed
lemma is_bcv_kildall: assumes "Semilat A r f"
shows "⟦ acc A r; top r T; pres_type step n A; bounded step n; mono r step n A ⟧
⟹ is_bcv r T step n A (kildall r f step)" (is "PROP ?P")
proof -
interpret Semilat A r f by fact
show "PROP ?P"
apply(unfold is_bcv_def wt_step_def)
apply(insert ‹Semilat A r f› semilat kildall_properties[of A])
apply(simp add:stables_def)
apply clarify
apply(subgoal_tac "kildall r f step τs⇩0 ∈ list n A")
prefer 2 apply (simp(no_asm_simp))
apply (rule iffI)
apply (rule_tac x = "kildall r f step τs⇩0" in bexI)
apply (rule conjI)
apply (blast)
apply (simp (no_asm_simp))
apply(assumption)
apply clarify
apply(subgoal_tac "kildall r f step τs⇩0!p <=_r τs!p")
apply simp
apply (blast intro!: le_listD less_lengthI)
done
qed
end
interpretation Kildall "set" "[]" "λxs. xs = []" "hd" "removeAll" "Cons"
by(unfold_locales) auto
lemmas kildall_code [code] =
kildall_def
Kildall_base.propa.simps
Kildall_base.iter_def
Kildall_base.unstables_def
Kildall_base.kildall_def
end
Theory LBVSpec
section ‹The Lightweight Bytecode Verifier›
theory LBVSpec
imports SemilatAlg Opt
begin
type_synonym
's certificate = "'s list"
primrec merge :: "'s certificate ⇒ 's binop ⇒ 's ord ⇒ 's ⇒ nat ⇒ (nat × 's) list ⇒ 's ⇒ 's"
where
"merge cert f r T pc [] x = x"
| "merge cert f r T pc (s#ss) x = merge cert f r T pc ss (let (pc',s') = s in
if pc'=pc+1 then s' ⊔⇩f x
else if s' ⊑⇩r cert!pc' then x
else T)"
definition wtl_inst :: "'s certificate ⇒ 's binop ⇒ 's ord ⇒ 's ⇒
's step_type ⇒ nat ⇒ 's ⇒ 's"
where
"wtl_inst cert f r T step pc s = merge cert f r T pc (step pc s) (cert!(pc+1))"
definition wtl_cert :: "'s certificate ⇒ 's binop ⇒ 's ord ⇒ 's ⇒ 's ⇒
's step_type ⇒ nat ⇒ 's ⇒ 's"
where
"wtl_cert cert f r T B step pc s =
(if cert!pc = B then
wtl_inst cert f r T step pc s
else
if s ⊑⇩r cert!pc then wtl_inst cert f r T step pc (cert!pc) else T)"
primrec wtl_inst_list :: "'a list ⇒ 's certificate ⇒ 's binop ⇒ 's ord ⇒ 's ⇒ 's ⇒
's step_type ⇒ nat ⇒ 's ⇒ 's"
where
"wtl_inst_list [] cert f r T B step pc s = s"
| "wtl_inst_list (i#is) cert f r T B step pc s =
(let s' = wtl_cert cert f r T B step pc s in
if s' = T ∨ s = T then T else wtl_inst_list is cert f r T B step (pc+1) s')"
definition cert_ok :: "'s certificate ⇒ nat ⇒ 's ⇒ 's ⇒ 's set ⇒ bool"
where
"cert_ok cert n T B A ⟷ (∀i < n. cert!i ∈ A ∧ cert!i ≠ T) ∧ (cert!n = B)"
definition bottom :: "'a ord ⇒ 'a ⇒ bool"
where
"bottom r B ⟷ (∀x. B ⊑⇩r x)"
locale lbv = Semilat +
fixes T :: "'a" ("⊤")
fixes B :: "'a" ("⊥")
fixes step :: "'a step_type"
assumes top: "top r ⊤"
assumes T_A: "⊤ ∈ A"
assumes bot: "bottom r ⊥"
assumes B_A: "⊥ ∈ A"
fixes merge :: "'a certificate ⇒ nat ⇒ (nat × 'a) list ⇒ 'a ⇒ 'a"
defines mrg_def: "merge cert ≡ LBVSpec.merge cert f r ⊤"
fixes wti :: "'a certificate ⇒ nat ⇒ 'a ⇒ 'a"
defines wti_def: "wti cert ≡ wtl_inst cert f r ⊤ step"
fixes wtc :: "'a certificate ⇒ nat ⇒ 'a ⇒ 'a"
defines wtc_def: "wtc cert ≡ wtl_cert cert f r ⊤ ⊥ step"
fixes wtl :: "'b list ⇒ 'a certificate ⇒ nat ⇒ 'a ⇒ 'a"
defines wtl_def: "wtl ins cert ≡ wtl_inst_list ins cert f r ⊤ ⊥ step"
lemma (in lbv) wti:
"wti c pc s = merge c pc (step pc s) (c!(pc+1))"
by (simp add: wti_def mrg_def wtl_inst_def)
lemma (in lbv) wtc:
"wtc c pc s = (if c!pc = ⊥ then wti c pc s else if s ⊑⇩r c!pc then wti c pc (c!pc) else ⊤)"
by (unfold wtc_def wti_def wtl_cert_def) rule
lemma cert_okD1 [intro?]:
"cert_ok c n T B A ⟹ pc < n ⟹ c!pc ∈ A"
by (unfold cert_ok_def) fast
lemma cert_okD2 [intro?]:
"cert_ok c n T B A ⟹ c!n = B"
by (simp add: cert_ok_def)
lemma cert_okD3 [intro?]:
"cert_ok c n T B A ⟹ B ∈ A ⟹ pc < n ⟹ c!Suc pc ∈ A"
by (drule Suc_leI) (auto simp add: le_eq_less_or_eq dest: cert_okD1 cert_okD2)
lemma cert_okD4 [intro?]:
"cert_ok c n T B A ⟹ pc < n ⟹ c!pc ≠ T"
by (simp add: cert_ok_def)
declare Let_def [simp]
subsection "more semilattice lemmas"
lemma (in lbv) sup_top [simp, elim]:
assumes x: "x ∈ A"
shows "x ⊔⇩f ⊤ = ⊤"
proof -
from top have "x ⊔⇩f ⊤ ⊑⇩r ⊤" ..
moreover from x T_A have "⊤ ⊑⇩r x ⊔⇩f ⊤" ..
ultimately show ?thesis ..
qed
lemma (in lbv) plusplussup_top [simp, elim]:
"set xs ⊆ A ⟹ xs ⨆⇘f⇙ ⊤ = ⊤"
by (induct xs) auto
lemma (in Semilat) pp_ub1':
assumes S: "snd`set S ⊆ A"
assumes y: "y ∈ A" and ab: "(a, b) ∈ set S"
shows "b ⊑⇩r map snd [(p', t') ← S . p' = a] ⨆⇘f⇙ y"
proof -
from S have "∀(x,y) ∈ set S. y ∈ A" by auto
with Semilat_axioms show ?thesis using y ab by (rule ub1')
qed
lemma (in lbv) bottom_le [simp, intro!]: "⊥ ⊑⇩r x"
by (insert bot) (simp add: bottom_def)
lemma (in lbv) le_bottom [simp]: "x ⊑⇩r ⊥ = (x = ⊥)"
by (blast intro: antisym_r)
subsection "merge"
lemma (in lbv) merge_Nil [simp]:
"merge c pc [] x = x" by (simp add: mrg_def)
lemma (in lbv) merge_Cons [simp]:
"merge c pc (l#ls) x = merge c pc ls (if fst l=pc+1 then snd l +_f x
else if snd l ⊑⇩r c!fst l then x
else ⊤)"
by (simp add: mrg_def split_beta)
lemma (in lbv) merge_Err [simp]:
"snd`set ss ⊆ A ⟹ merge c pc ss ⊤ = ⊤"
by (induct ss) auto
lemma (in lbv) merge_not_top:
"⋀x. snd`set ss ⊆ A ⟹ merge c pc ss x ≠ ⊤ ⟹
∀(pc',s') ∈ set ss. (pc' ≠ pc+1 ⟶ s' ⊑⇩r c!pc')"
(is "⋀x. ?set ss ⟹ ?merge ss x ⟹ ?P ss")
proof (induct ss)
show "?P []" by simp
next
fix x ls l
assume "?set (l#ls)" then obtain set: "snd`set ls ⊆ A" by simp
assume merge: "?merge (l#ls) x"
moreover
obtain pc' s' where [simp]: "l = (pc',s')" by (cases l)
ultimately
obtain x' where merge': "?merge ls x'" by simp
assume "⋀x. ?set ls ⟹ ?merge ls x ⟹ ?P ls" hence "?P ls" using set merge' .
moreover
from merge set
have "pc' ≠ pc+1 ⟶ s' ⊑⇩r c!pc'" by (simp split: if_split_asm)
ultimately show "?P (l#ls)" by simp
qed
lemma (in lbv) merge_def:
shows
"⋀x. x ∈ A ⟹ snd`set ss ⊆ A ⟹
merge c pc ss x =
(if ∀(pc',s') ∈ set ss. pc'≠pc+1 ⟶ s' ⊑⇩r c!pc' then
map snd [(p',t') ← ss. p'=pc+1] ⨆⇘f⇙ x
else ⊤)"
(is "⋀x. _ ⟹ _ ⟹ ?merge ss x = ?if ss x" is "⋀x. _ ⟹ _ ⟹ ?P ss x")
proof (induct ss)
fix x show "?P [] x" by simp
next
fix x assume x: "x ∈ A"
fix l::"nat × 'a" and ls
assume "snd`set (l#ls) ⊆ A"
then obtain l: "snd l ∈ A" and ls: "snd`set ls ⊆ A" by auto
assume "⋀x. x ∈ A ⟹ snd`set ls ⊆ A ⟹ ?P ls x"
hence IH: "⋀x. x ∈ A ⟹ ?P ls x" using ls by iprover
obtain pc' s' where [simp]: "l = (pc',s')" by (cases l)
hence "?merge (l#ls) x = ?merge ls
(if pc'=pc+1 then s' ⊔⇩f x else if s' ⊑⇩r c!pc' then x else ⊤)"
(is "?merge (l#ls) x = ?merge ls ?if'")
by simp
also have "… = ?if ls ?if'"
proof -
from l have "s' ∈ A" by simp
with x have "s' ⊔⇩f x ∈ A" by simp
with x T_A have "?if' ∈ A" by auto
hence "?P ls ?if'" by (rule IH) thus ?thesis by simp
qed
also have "… = ?if (l#ls) x"
proof (cases "∀(pc', s')∈set (l#ls). pc'≠pc+1 ⟶ s' ⊑⇩r c!pc'")
case True
hence "∀(pc', s')∈set ls. pc'≠pc+1 ⟶ s' ⊑⇩r c!pc'" by auto
moreover
from True have
"map snd [(p',t') ← ls . p'=pc+1] ⨆⇘f⇙ ?if' =
(map snd [(p',t') ← l#ls . p'=pc+1] ⨆⇘f⇙ x)"
by simp
ultimately
show ?thesis using True by simp
next
case False
moreover
from ls have "set (map snd [(p', t') ← ls . p' = Suc pc]) ⊆ A" by auto
ultimately show ?thesis by auto
qed
finally show "?P (l#ls) x" .
qed
lemma (in lbv) merge_not_top_s:
assumes x: "x ∈ A" and ss: "snd`set ss ⊆ A"
assumes m: "merge c pc ss x ≠ ⊤"
shows "merge c pc ss x = (map snd [(p',t') ← ss. p'=pc+1] ⨆⇘f⇙ x)"
proof -
from ss m have "∀(pc',s') ∈ set ss. (pc' ≠ pc+1 ⟶ s' <=_r c!pc')"
by (rule merge_not_top)
with x ss m show ?thesis by - (drule merge_def, auto split: if_split_asm)
qed
subsection "wtl-inst-list"
lemmas [iff] = not_Err_eq
lemma (in lbv) wtl_Nil [simp]: "wtl [] c pc s = s"
by (simp add: wtl_def)
lemma (in lbv) wtl_Cons [simp]:
"wtl (i#is) c pc s =
(let s' = wtc c pc s in if s' = ⊤ ∨ s = ⊤ then ⊤ else wtl is c (pc+1) s')"
by (simp add: wtl_def wtc_def)
lemma (in lbv) wtl_Cons_not_top:
"wtl (i#is) c pc s ≠ ⊤ =
(wtc c pc s ≠ ⊤ ∧ s ≠ T ∧ wtl is c (pc+1) (wtc c pc s) ≠ ⊤)"
by (auto simp del: split_paired_Ex)
lemma (in lbv) wtl_top [simp]: "wtl ls c pc ⊤ = ⊤"
by (cases ls) auto
lemma (in lbv) wtl_not_top:
"wtl ls c pc s ≠ ⊤ ⟹ s ≠ ⊤"
by (cases "s=⊤") auto
lemma (in lbv) wtl_append [simp]:
"⋀pc s. wtl (a@b) c pc s = wtl b c (pc+length a) (wtl a c pc s)"
by (induct a) auto
lemma (in lbv) wtl_take:
"wtl is c pc s ≠ ⊤ ⟹ wtl (take pc' is) c pc s ≠ ⊤"
(is "?wtl is ≠ _ ⟹ _")
proof -
assume "?wtl is ≠ ⊤"
hence "?wtl (take pc' is @ drop pc' is) ≠ ⊤" by simp
thus ?thesis by (auto dest!: wtl_not_top simp del: append_take_drop_id)
qed
lemma take_Suc:
"∀n. n < length l ⟶ take (Suc n) l = (take n l)@[l!n]" (is "?P l")
proof (induct l)
show "?P []" by simp
next
fix x xs assume IH: "?P xs"
show "?P (x#xs)"
proof (intro strip)
fix n assume "n < length (x#xs)"
with IH show "take (Suc n) (x # xs) = take n (x # xs) @ [(x # xs) ! n]"
by (cases n, auto)
qed
qed
lemma (in lbv) wtl_Suc:
assumes suc: "pc+1 < length is"
assumes wtl: "wtl (take pc is) c 0 s ≠ ⊤"
shows "wtl (take (pc+1) is) c 0 s = wtc c pc (wtl (take pc is) c 0 s)"
proof -
from suc have "take (pc+1) is=(take pc is)@[is!pc]" by (simp add: take_Suc)
with suc wtl show ?thesis by (simp add: min_def)
qed
lemma (in lbv) wtl_all:
assumes all: "wtl is c 0 s ≠ ⊤" (is "?wtl is ≠ _")
assumes pc: "pc < length is"
shows "wtc c pc (wtl (take pc is) c 0 s) ≠ ⊤"
proof -
from pc have "0 < length (drop pc is)" by simp
then obtain i r where Cons: "drop pc is = i#r"
by (auto simp add: neq_Nil_conv simp del: length_drop drop_eq_Nil)
hence "i#r = drop pc is" ..
with all have take: "?wtl (take pc is@i#r) ≠ ⊤" by simp
from pc have "is!pc = drop pc is ! 0" by simp
with Cons have "is!pc = i" by simp
with take pc show ?thesis by (auto simp add: min_def split: if_split_asm)
qed
subsection "preserves-type"
lemma (in lbv) merge_pres:
assumes s0: "snd`set ss ⊆ A" and x: "x ∈ A"
shows "merge c pc ss x ∈ A"
proof -
from s0 have "set (map snd [(p', t') ← ss . p'=pc+1]) ⊆ A" by auto
with x semilat Semilat_axioms have "(map snd [(p', t') ← ss . p'=pc+1] ⨆⇘f⇙ x) ∈ A"
by (auto intro!: plusplus_closed)
with s0 x show ?thesis by (simp add: merge_def T_A)
qed
lemma pres_typeD2:
"pres_type step n A ⟹ s ∈ A ⟹ p < n ⟹ snd`set (step p s) ⊆ A"
by auto (drule pres_typeD)
lemma (in lbv) wti_pres [intro?]:
assumes pres: "pres_type step n A"
assumes cert: "c!(pc+1) ∈ A"
assumes s_pc: "s ∈ A" "pc < n"
shows "wti c pc s ∈ A"
proof -
from pres s_pc have "snd`set (step pc s) ⊆ A" by (rule pres_typeD2)
with cert show ?thesis by (simp add: wti merge_pres)
qed
lemma (in lbv) wtc_pres:
assumes "pres_type step n A"
assumes "c!pc ∈ A" and "c!(pc+1) ∈ A"
assumes "s ∈ A" and "pc < n"
shows "wtc c pc s ∈ A"
proof -
have "wti c pc s ∈ A" using assms(1,3-5) ..
moreover have "wti c pc (c!pc) ∈ A" using assms(1,3,2,5) ..
ultimately show ?thesis using T_A by (simp add: wtc)
qed
lemma (in lbv) wtl_pres:
assumes pres: "pres_type step (length is) A"
assumes cert: "cert_ok c (length is) ⊤ ⊥ A"
assumes s: "s ∈ A"
assumes all: "wtl is c 0 s ≠ ⊤"
shows "pc < length is ⟹ wtl (take pc is) c 0 s ∈ A"
(is "?len pc ⟹ ?wtl pc ∈ A")
proof (induct pc)
from s show "?wtl 0 ∈ A" by simp
next
fix n assume Suc_n: "Suc n < length is"
hence n1: "n+1 < length is" by simp
then obtain n: "n < length is" by simp
assume "n < length is ⟹ ?wtl n ∈ A"
hence "?wtl n ∈ A" using n .
from pres _ _ this n
have "wtc c n (?wtl n) ∈ A"
proof (rule wtc_pres)
from cert n show "c!n ∈ A" by (rule cert_okD1)
from cert n1 show "c!(n+1) ∈ A" by (rule cert_okD1)
qed
also
from all n have "?wtl n ≠ ⊤" by - (rule wtl_take)
with n1 have "wtc c n (?wtl n) = ?wtl (n+1)" by (rule wtl_Suc [symmetric])
finally show "?wtl (Suc n) ∈ A" by simp
qed
end
Theory LBVCorrect
section ‹Correctness of the LBV›
theory LBVCorrect
imports LBVSpec Typing_Framework
begin
locale lbvs = lbv +
fixes s⇩0 :: 'a
fixes c :: "'a list"
fixes ins :: "'b list"
fixes τs :: "'a list"
defines phi_def:
"τs ≡ map (λpc. if c!pc = ⊥ then wtl (take pc ins) c 0 s⇩0 else c!pc)
[0..<size ins]"
assumes bounded: "bounded step (size ins)"
assumes cert: "cert_ok c (size ins) ⊤ ⊥ A"
assumes pres: "pres_type step (size ins) A"
lemma (in lbvs) phi_None [intro?]:
"⟦ pc < size ins; c!pc = ⊥ ⟧ ⟹ τs!pc = wtl (take pc ins) c 0 s⇩0"
by (simp add: phi_def)
lemma (in lbvs) phi_Some [intro?]:
"⟦ pc < size ins; c!pc ≠ ⊥ ⟧ ⟹ τs!pc = c!pc"
by (simp add: phi_def)
lemma (in lbvs) phi_len [simp]: "size τs = size ins"
by (simp add: phi_def)
lemma (in lbvs) wtl_suc_pc:
assumes all: "wtl ins c 0 s⇩0 ≠ ⊤"
assumes pc: "pc+1 < size ins"
shows "wtl (take (pc+1) ins) c 0 s⇩0 ⊑⇩r τs!(pc+1)"
proof -
from all pc
have "wtc c (pc+1) (wtl (take (pc+1) ins) c 0 s⇩0) ≠ T" by (rule wtl_all)
with pc show ?thesis by (simp add: phi_def wtc split: if_split_asm)
qed
lemma (in lbvs) wtl_stable:
assumes wtl: "wtl ins c 0 s⇩0 ≠ ⊤"
assumes s⇩0: "s⇩0 ∈ A" and pc: "pc < size ins"
shows "stable r step τs pc"
proof (unfold stable_def, clarify)
fix pc' s' assume step: "(pc',s') ∈ set (step pc (τs ! pc))"
(is "(pc',s') ∈ set (?step pc)")
from bounded pc step have pc': "pc' < size ins" by (rule boundedD)
have tkpc: "wtl (take pc ins) c 0 s⇩0 ≠ ⊤" (is "?s⇩1 ≠ _") using wtl by (rule wtl_take)
have s⇩2: "wtl (take (pc+1) ins) c 0 s⇩0 ≠ ⊤" (is "?s⇩2 ≠ _") using wtl by (rule wtl_take)
from wtl pc have wt_s⇩1: "wtc c pc ?s⇩1 ≠ ⊤" by (rule wtl_all)
have c_Some: "∀pc t. pc < size ins ⟶ c!pc ≠ ⊥ ⟶ τs!pc = c!pc"
by (simp add: phi_def)
have c_None: "c!pc = ⊥ ⟹ τs!pc = ?s⇩1" using pc ..
from wt_s⇩1 pc c_None c_Some
have inst: "wtc c pc ?s⇩1 = wti c pc (τs!pc)"
by (simp add: wtc split: if_split_asm)
have "?s⇩1 ∈ A" using pres cert s⇩0 wtl pc by (rule wtl_pres)
with pc c_Some cert c_None
have "τs!pc ∈ A" by (cases "c!pc = ⊥") (auto dest: cert_okD1)
with pc pres
have step_in_A: "snd`set (?step pc) ⊆ A" by (auto dest: pres_typeD2)
show "s' ⊑⇩r τs!pc'"
proof (cases "pc' = pc+1")
case True
with pc' cert
have cert_in_A: "c!(pc+1) ∈ A" by (auto dest: cert_okD1)
from True pc' have pc1: "pc+1 < size ins" by simp
with tkpc have "?s⇩2 = wtc c pc ?s⇩1" by - (rule wtl_Suc)
with inst
have merge: "?s⇩2 = merge c pc (?step pc) (c!(pc+1))" by (simp add: wti)
also from s⇩2 merge have "… ≠ ⊤" (is "?merge ≠ _") by simp
with cert_in_A step_in_A
have "?merge = (map snd [(p',t') ← ?step pc. p'=pc+1] ⨆⇘f⇙ c!(pc+1))"
by (rule merge_not_top_s)
finally have "s' ⊑⇩r ?s⇩2" using step_in_A cert_in_A True step
by (auto intro: pp_ub1')
also from wtl pc1 have "?s⇩2 ⊑⇩r τs!(pc+1)" by (rule wtl_suc_pc)
also note True [symmetric]
finally show ?thesis by simp
next
case False
from wt_s⇩1 inst
have "merge c pc (?step pc) (c!(pc+1)) ≠ ⊤" by (simp add: wti)
with step_in_A have "∀(pc', s')∈set (?step pc). pc'≠pc+1 ⟶ s' ⊑⇩r c!pc'"
by - (rule merge_not_top)
with step False have ok: "s' ⊑⇩r c!pc'" by blast
moreover from ok have "c!pc' = ⊥ ⟹ s' = ⊥" by simp
moreover from c_Some pc' have "c!pc' ≠ ⊥ ⟹ τs!pc' = c!pc'" by auto
ultimately show ?thesis by (cases "c!pc' = ⊥") auto
qed
qed
lemma (in lbvs) phi_not_top:
assumes wtl: "wtl ins c 0 s⇩0 ≠ ⊤" and pc: "pc < size ins"
shows "τs!pc ≠ ⊤"
proof (cases "c!pc = ⊥")
case False with pc
have "τs!pc = c!pc" ..
also from cert pc have "… ≠ ⊤" by (rule cert_okD4)
finally show ?thesis .
next
case True with pc
have "τs!pc = wtl (take pc ins) c 0 s⇩0" ..
also from wtl have "… ≠ ⊤" by (rule wtl_take)
finally show ?thesis .
qed
lemma (in lbvs) phi_in_A:
assumes wtl: "wtl ins c 0 s⇩0 ≠ ⊤" and s⇩0: "s⇩0 ∈ A"
shows "τs ∈ list (size ins) A"
proof -
{ fix x assume "x ∈ set τs"
then obtain xs ys where "τs = xs @ x # ys"
by (auto simp add: in_set_conv_decomp)
then obtain pc where pc: "pc < size τs" and x: "τs!pc = x"
by (simp add: that [of "size xs"] nth_append)
from pres cert wtl s⇩0 pc
have "wtl (take pc ins) c 0 s⇩0 ∈ A" by (auto intro!: wtl_pres)
moreover
from pc have "pc < size ins" by simp
with cert have "c!pc ∈ A" ..
ultimately
have "τs!pc ∈ A" using pc by (simp add: phi_def)
hence "x ∈ A" using x by simp
}
hence "set τs ⊆ A" ..
thus ?thesis by (unfold list_def) simp
qed
lemma (in lbvs) phi0:
assumes wtl: "wtl ins c 0 s⇩0 ≠ ⊤" and 0: "0 < size ins"
shows "s⇩0 ⊑⇩r τs!0"
proof (cases "c!0 = ⊥")
case True
with 0 have "τs!0 = wtl (take 0 ins) c 0 s⇩0" ..
moreover have "wtl (take 0 ins) c 0 s⇩0 = s⇩0" by simp
ultimately have "τs!0 = s⇩0" by simp
thus ?thesis by simp
next
case False
with 0 have "τs!0 = c!0" ..
moreover
have "wtl (take 1 ins) c 0 s⇩0 ≠ ⊤" using wtl by (rule wtl_take)
with 0 False
have "s⇩0 ⊑⇩r c!0" by (auto simp add: neq_Nil_conv wtc split: if_split_asm)
ultimately
show ?thesis by simp
qed
theorem (in lbvs) wtl_sound:
assumes wtl: "wtl ins c 0 s⇩0 ≠ ⊤" and s⇩0: "s⇩0 ∈ A"
shows "∃τs. wt_step r ⊤ step τs"
proof -
have "wt_step r ⊤ step τs"
proof (unfold wt_step_def, intro strip conjI)
fix pc assume "pc < size τs"
then obtain pc: "pc < size ins" by simp
with wtl show "τs!pc ≠ ⊤" by (rule phi_not_top)
from wtl s⇩0 pc show "stable r step τs pc" by (rule wtl_stable)
qed
thus ?thesis ..
qed
theorem (in lbvs) wtl_sound_strong:
assumes wtl: "wtl ins c 0 s⇩0 ≠ ⊤"
assumes s⇩0: "s⇩0 ∈ A" and ins: "0 < size ins"
shows "∃τs ∈ list (size ins) A. wt_step r ⊤ step τs ∧ s⇩0 ⊑⇩r τs!0"
proof -
have "τs ∈ list (size ins) A" using wtl s⇩0 by (rule phi_in_A)
moreover
have "wt_step r ⊤ step τs"
proof (unfold wt_step_def, intro strip conjI)
fix pc assume "pc < size τs"
then obtain pc: "pc < size ins" by simp
with wtl show "τs!pc ≠ ⊤" by (rule phi_not_top)
from wtl s⇩0 and pc show "stable r step τs pc" by (rule wtl_stable)
qed
moreover from wtl ins have "s⇩0 ⊑⇩r τs!0" by (rule phi0)
ultimately show ?thesis by fast
qed
end
Theory LBVComplete
section ‹Completeness of the LBV›
theory LBVComplete
imports LBVSpec Typing_Framework
begin
definition is_target :: "'s step_type ⇒ 's list ⇒ nat ⇒ bool" where
"is_target step τs pc' ⟷ (∃pc s'. pc' ≠ pc+1 ∧ pc < size τs ∧ (pc',s') ∈ set (step pc (τs!pc)))"
definition make_cert :: "'s step_type ⇒ 's list ⇒ 's ⇒ 's certificate" where
"make_cert step τs B = map (λpc. if is_target step τs pc then τs!pc else B) [0..<size τs] @ [B]"
lemma [code]:
"is_target step τs pc' =
list_ex (λpc. pc' ≠ pc+1 ∧ List.member (map fst (step pc (τs!pc))) pc') [0..<size τs]"
apply (simp add: list_ex_iff is_target_def member_def)
apply force
done
locale lbvc = lbv +
fixes τs :: "'a list"
fixes c :: "'a list"
defines cert_def: "c ≡ make_cert step τs ⊥"
assumes mono: "mono r step (size τs) A"
assumes pres: "pres_type step (size τs) A"
assumes τs: "∀pc < size τs. τs!pc ∈ A ∧ τs!pc ≠ ⊤"
assumes bounded: "bounded step (size τs)"
assumes B_neq_T: "⊥ ≠ ⊤"
lemma (in lbvc) cert: "cert_ok c (size τs) ⊤ ⊥ A"
proof (unfold cert_ok_def, intro strip conjI)
note [simp] = make_cert_def cert_def nth_append
show "c!size τs = ⊥" by simp
fix pc assume pc: "pc < size τs"
from pc τs B_A show "c!pc ∈ A" by simp
from pc τs B_neq_T show "c!pc ≠ ⊤" by simp
qed
lemmas [simp del] = split_paired_Ex
lemma (in lbvc) cert_target [intro?]:
"⟦ (pc',s') ∈ set (step pc (τs!pc));
pc' ≠ pc+1; pc < size τs; pc' < size τs ⟧
⟹ c!pc' = τs!pc'"
by (auto simp add: cert_def make_cert_def nth_append is_target_def)
lemma (in lbvc) cert_approx [intro?]:
"⟦ pc < size τs; c!pc ≠ ⊥ ⟧ ⟹ c!pc = τs!pc"
by (auto simp add: cert_def make_cert_def nth_append)
lemma (in lbv) le_top [simp, intro]: "x <=_r ⊤"
by (insert top) simp
lemma (in lbv) merge_mono:
assumes less: "set ss⇩2 {⊑⇘r⇙} set ss⇩1"
assumes x: "x ∈ A"
assumes ss⇩1: "snd`set ss⇩1 ⊆ A"
assumes ss⇩2: "snd`set ss⇩2 ⊆ A"
shows "merge c pc ss⇩2 x ⊑⇩r merge c pc ss⇩1 x" (is "?s⇩2 ⊑⇩r ?s⇩1")
proof-
have "?s⇩1 = ⊤ ⟹ ?thesis" by simp
moreover {
assume merge: "?s⇩1 ≠ T"
from x ss⇩1 have "?s⇩1 =
(if ∀(pc',s')∈set ss⇩1. pc' ≠ pc + 1 ⟶ s' ⊑⇩r c!pc'
then (map snd [(p', t') ← ss⇩1 . p'=pc+1]) ⨆⇘f⇙ x
else ⊤)" by (rule merge_def)
with merge obtain
app: "∀(pc',s')∈set ss⇩1. pc' ≠ pc+1 ⟶ s' ⊑⇩r c!pc'"
(is "?app ss⇩1") and
sum: "(map snd [(p',t') ← ss⇩1 . p' = pc+1] ⨆⇘f⇙ x) = ?s⇩1"
(is "?map ss⇩1 ⨆⇘f⇙ x = _" is "?sum ss⇩1 = _")
by (simp split: if_split_asm)
from app less have "?app ss⇩2" by (blast dest: trans_r lesub_step_typeD)
moreover {
from ss⇩1 have map1: "set (?map ss⇩1) ⊆ A" by auto
with x and semilat Semilat_axioms have "?sum ss⇩1 ∈ A" by (auto intro!: plusplus_closed)
with sum have "?s⇩1 ∈ A" by simp
moreover
have mapD: "⋀x ss. x ∈ set (?map ss) ⟹ ∃p. (p,x) ∈ set ss ∧ p=pc+1" by auto
from x map1 have "∀x ∈ set (?map ss⇩1). x ⊑⇩r ?sum ss⇩1" by clarify (rule pp_ub1)
with sum have "∀x ∈ set (?map ss⇩1). x ⊑⇩r ?s⇩1" by simp
with less have "∀x ∈ set (?map ss⇩2). x ⊑⇩r ?s⇩1"
by (fastforce dest!: mapD lesub_step_typeD intro: trans_r)
moreover from map1 x have "x ⊑⇩r (?sum ss⇩1)" by (rule pp_ub2)
with sum have "x ⊑⇩r ?s⇩1" by simp
moreover from ss⇩2 have "set (?map ss⇩2) ⊆ A" by auto
ultimately have "?sum ss⇩2 ⊑⇩r ?s⇩1" using x by - (rule pp_lub)
}
moreover from x ss⇩2 have "?s⇩2 =
(if ∀(pc', s')∈set ss⇩2. pc' ≠ pc + 1 ⟶ s' ⊑⇩r c!pc'
then map snd [(p', t') ← ss⇩2 . p' = pc + 1] ⨆⇘f⇙ x
else ⊤)" by (rule merge_def)
ultimately have ?thesis by simp
}
ultimately show ?thesis by (cases "?s⇩1 = ⊤") auto
qed
lemma (in lbvc) wti_mono:
assumes less: "s⇩2 ⊑⇩r s⇩1"
assumes pc: "pc < size τs" and s⇩1: "s⇩1 ∈ A" and s⇩2: "s⇩2 ∈ A"
shows "wti c pc s⇩2 ⊑⇩r wti c pc s⇩1" (is "?s⇩2' ⊑⇩r ?s⇩1'")
proof -
from mono pc s⇩2 less have "set (step pc s⇩2) {⊑⇘r⇙} set (step pc s⇩1)" by (rule monoD)
moreover from cert B_A pc have "c!Suc pc ∈ A" by (rule cert_okD3)
moreover from pres s⇩1 pc have "snd`set (step pc s⇩1) ⊆ A" by (rule pres_typeD2)
moreover from pres s⇩2 pc have "snd`set (step pc s⇩2) ⊆ A" by (rule pres_typeD2)
ultimately show ?thesis by (simp add: wti merge_mono)
qed
lemma (in lbvc) wtc_mono:
assumes less: "s⇩2 ⊑⇩r s⇩1"
assumes pc: "pc < size τs" and s⇩1: "s⇩1 ∈ A" and s⇩2: "s⇩2 ∈ A"
shows "wtc c pc s⇩2 ⊑⇩r wtc c pc s⇩1" (is "?s⇩2' ⊑⇩r ?s⇩1'")
proof (cases "c!pc = ⊥")
case True
moreover from less pc s⇩1 s⇩2 have "wti c pc s⇩2 ⊑⇩r wti c pc s⇩1" by (rule wti_mono)
ultimately show ?thesis by (simp add: wtc)
next
case False
have "?s⇩1' = ⊤ ⟹ ?thesis" by simp
moreover {
assume "?s⇩1' ≠ ⊤"
with False have c: "s⇩1 ⊑⇩r c!pc" by (simp add: wtc split: if_split_asm)
with less have "s⇩2 ⊑⇩r c!pc" ..
with False c have ?thesis by (simp add: wtc)
}
ultimately show ?thesis by (cases "?s⇩1' = ⊤") auto
qed
lemma (in lbv) top_le_conv [simp]: "⊤ ⊑⇩r x = (x = ⊤)"
by (insert semilat) (simp add: top top_le_conv)
lemma (in lbv) neq_top [simp, elim]: "⟦ x ⊑⇩r y; y ≠ ⊤ ⟧ ⟹ x ≠ ⊤"
by (cases "x = T") auto
lemma (in lbvc) stable_wti:
assumes stable: "stable r step τs pc" and pc: "pc < size τs"
shows "wti c pc (τs!pc) ≠ ⊤"
proof -
let ?step = "step pc (τs!pc)"
from stable
have less: "∀(q,s')∈set ?step. s' ⊑⇩r τs!q" by (simp add: stable_def)
from cert B_A pc have cert_suc: "c!Suc pc ∈ A" by (rule cert_okD3)
moreover from τs pc have "τs!pc ∈ A" by simp
with pres pc have stepA: "snd`set ?step ⊆ A" by - (rule pres_typeD2)
ultimately
have "merge c pc ?step (c!Suc pc) =
(if ∀(pc',s')∈set ?step. pc'≠pc+1 ⟶ s' ⊑⇩r c!pc'
then map snd [(p',t') ← ?step.p'=pc+1] ⨆⇘f⇙ c!Suc pc
else ⊤)" unfolding mrg_def by (rule lbv.merge_def [OF lbvc.axioms(1), OF lbvc_axioms])
moreover {
fix pc' s' assume s': "(pc',s') ∈ set ?step" and suc_pc: "pc' ≠ pc+1"
with less have "s' ⊑⇩r τs!pc'" by auto
also from bounded pc s' have "pc' < size τs" by (rule boundedD)
with s' suc_pc pc have "c!pc' = τs!pc'" ..
hence "τs!pc' = c!pc'" ..
finally have "s' ⊑⇩r c!pc'" .
} hence "∀(pc',s')∈set ?step. pc'≠pc+1 ⟶ s' ⊑⇩r c!pc'" by auto
moreover from pc have "Suc pc = size τs ∨ Suc pc < size τs" by auto
hence "map snd [(p',t') ← ?step.p'=pc+1] ⨆⇘f⇙ c!Suc pc ≠ ⊤" (is "?map ⨆⇘f⇙ _ ≠ _")
proof (rule disjE)
assume pc': "Suc pc = size τs"
with cert have "c!Suc pc = ⊥" by (simp add: cert_okD2)
moreover
from pc' bounded pc
have "∀(p',t')∈set ?step. p'≠pc+1" by clarify (drule boundedD, auto)
hence "[(p',t') ← ?step. p'=pc+1] = []" by (blast intro: filter_False)
hence "?map = []" by simp
ultimately show ?thesis by (simp add: B_neq_T)
next
assume pc': "Suc pc < size τs"
from pc' τs have "τs!Suc pc ∈ A" by simp
moreover note cert_suc
moreover from stepA have "set ?map ⊆ A" by auto
moreover have "⋀s. s ∈ set ?map ⟹ ∃t. (Suc pc, t) ∈ set ?step" by auto
with less have "∀s' ∈ set ?map. s' ⊑⇩r τs!Suc pc" by auto
moreover from pc' have "c!Suc pc ⊑⇩r τs!Suc pc"
by (cases "c!Suc pc = ⊥") (auto dest: cert_approx)
ultimately have "?map ⨆⇘f⇙ c!Suc pc ⊑⇩r τs!Suc pc" by (rule pp_lub)
moreover from pc' τs have "τs!Suc pc ≠ ⊤" by simp
ultimately show ?thesis by auto
qed
ultimately have "merge c pc ?step (c!Suc pc) ≠ ⊤" by simp
thus ?thesis by (simp add: wti)
qed
lemma (in lbvc) wti_less:
assumes stable: "stable r step τs pc" and suc_pc: "Suc pc < size τs"
shows "wti c pc (τs!pc) ⊑⇩r τs!Suc pc" (is "?wti ⊑⇩r _")
proof -
let ?step = "step pc (τs!pc)"
from stable
have less: "∀(q,s')∈set ?step. s' ⊑⇩r τs!q" by (simp add: stable_def)
from suc_pc have pc: "pc < size τs" by simp
with cert B_A have cert_suc: "c!Suc pc ∈ A" by (rule cert_okD3)
moreover from τs pc have "τs!pc ∈ A" by simp
with pres pc have stepA: "snd`set ?step ⊆ A" by - (rule pres_typeD2)
moreover from stable pc have "?wti ≠ ⊤" by (rule stable_wti)
hence "merge c pc ?step (c!Suc pc) ≠ ⊤" by (simp add: wti)
ultimately
have "merge c pc ?step (c!Suc pc) =
map snd [(p',t') ← ?step.p'=pc+1] ⨆⇘f⇙ c!Suc pc" by (rule merge_not_top_s)
hence "?wti = …" (is "_ = (?map ⨆⇘f⇙ _)" is "_ = ?sum") by (simp add: wti)
also {
from suc_pc τs have "τs!Suc pc ∈ A" by simp
moreover note cert_suc
moreover from stepA have "set ?map ⊆ A" by auto
moreover have "⋀s. s ∈ set ?map ⟹ ∃t. (Suc pc, t) ∈ set ?step" by auto
with less have "∀s' ∈ set ?map. s' ⊑⇩r τs!Suc pc" by auto
moreover from suc_pc have "c!Suc pc ⊑⇩r τs!Suc pc"
by (cases "c!Suc pc = ⊥") (auto dest: cert_approx)
ultimately have "?sum ⊑⇩r τs!Suc pc" by (rule pp_lub)
}
finally show ?thesis .
qed
lemma (in lbvc) stable_wtc:
assumes stable: "stable r step τs pc" and pc: "pc < size τs"
shows "wtc c pc (τs!pc) ≠ ⊤"
proof -
from stable pc have wti: "wti c pc (τs!pc) ≠ ⊤" by (rule stable_wti)
show ?thesis
proof (cases "c!pc = ⊥")
case True with wti show ?thesis by (simp add: wtc)
next
case False
with pc have "c!pc = τs!pc" ..
with False wti show ?thesis by (simp add: wtc)
qed
qed
lemma (in lbvc) wtc_less:
assumes stable: "stable r step τs pc" and suc_pc: "Suc pc < size τs"
shows "wtc c pc (τs!pc) ⊑⇩r τs!Suc pc" (is "?wtc ⊑⇩r _")
proof (cases "c!pc = ⊥")
case True
moreover from stable suc_pc have "wti c pc (τs!pc) ⊑⇩r τs!Suc pc" by (rule wti_less)
ultimately show ?thesis by (simp add: wtc)
next
case False
from suc_pc have pc: "pc < size τs" by simp
with stable have "?wtc ≠ ⊤" by (rule stable_wtc)
with False have "?wtc = wti c pc (c!pc)"
by (unfold wtc) (simp split: if_split_asm)
also from pc False have "c!pc = τs!pc" ..
finally have "?wtc = wti c pc (τs!pc)" .
also from stable suc_pc have "wti c pc (τs!pc) ⊑⇩r τs!Suc pc" by (rule wti_less)
finally show ?thesis .
qed
lemma (in lbvc) wt_step_wtl_lemma:
assumes wt_step: "wt_step r ⊤ step τs"
shows "⋀pc s. pc+size ls = size τs ⟹ s ⊑⇩r τs!pc ⟹ s ∈ A ⟹ s≠⊤ ⟹
wtl ls c pc s ≠ ⊤"
(is "⋀pc s. _ ⟹ _ ⟹ _ ⟹ _ ⟹ ?wtl ls pc s ≠ _")
proof (induct ls)
fix pc s assume "s≠⊤" thus "?wtl [] pc s ≠ ⊤" by simp
next
fix pc s i ls
assume "⋀pc s. pc+size ls=size τs ⟹ s ⊑⇩r τs!pc ⟹ s ∈ A ⟹ s≠⊤ ⟹
?wtl ls pc s ≠ ⊤"
moreover
assume pc_l: "pc + size (i#ls) = size τs"
hence suc_pc_l: "Suc pc + size ls = size τs" by simp
ultimately
have IH: "⋀s. s ⊑⇩r τs!Suc pc ⟹ s ∈ A ⟹ s ≠ ⊤ ⟹ ?wtl ls (Suc pc) s ≠ ⊤" .
from pc_l obtain pc: "pc < size τs" by simp
with wt_step have stable: "stable r step τs pc" by (simp add: wt_step_def)
moreover note pc
ultimately have wt_τs: "wtc c pc (τs!pc) ≠ ⊤" by (rule stable_wtc)
assume s_τs: "s ⊑⇩r τs!pc"
assume sA: "s ∈ A"
from τs pc have τs_pc: "τs!pc ∈ A" by simp
from s_τs pc τs_pc sA have wt_s_τs: "wtc c pc s ⊑⇩r wtc c pc (τs!pc)" by (rule wtc_mono)
with wt_τs have wt_s: "wtc c pc s ≠ ⊤" by simp
moreover assume s: "s ≠ ⊤"
ultimately have "ls = [] ⟹ ?wtl (i#ls) pc s ≠ ⊤" by simp
moreover {
assume "ls ≠ []"
with pc_l have suc_pc: "Suc pc < size τs" by (auto simp add: neq_Nil_conv)
with stable have "wtc c pc (τs!pc) ⊑⇩r τs!Suc pc" by (rule wtc_less)
with wt_s_τs have "wtc c pc s ⊑⇩r τs!Suc pc" by (rule trans_r)
moreover from cert suc_pc have "c!pc ∈ A" "c!(pc+1) ∈ A"
by (auto simp add: cert_ok_def)
from pres this sA pc have "wtc c pc s ∈ A" by (rule wtc_pres)
ultimately have "?wtl ls (Suc pc) (wtc c pc s) ≠ ⊤" using IH wt_s by blast
with s wt_s have "?wtl (i#ls) pc s ≠ ⊤" by simp
}
ultimately show "?wtl (i#ls) pc s ≠ ⊤" by (cases ls) blast+
qed
theorem (in lbvc) wtl_complete:
assumes wt: "wt_step r ⊤ step τs"
assumes s: "s ⊑⇩r τs!0" "s ∈ A" "s ≠ ⊤" and eq: "size ins = size τs"
shows "wtl ins c 0 s ≠ ⊤"
proof -
from eq have "0+size ins = size τs" by simp
from wt this s show ?thesis by (rule wt_step_wtl_lemma)
qed
end
Theory Type
chapter ‹Concepts for all JinjaThreads Languages \label{cha:j}›
section ‹JinjaThreads types›
theory Type
imports
"../Basic/Auxiliary"
begin
type_synonym cname = String.literal
type_synonym mname = String.literal
type_synonym vname = String.literal
definition Object :: cname
where "Object ≡ STR ''java/lang/Object''"
definition Thread :: cname
where "Thread ≡ STR ''java/lang/Thread''"
definition Throwable :: cname
where "Throwable ≡ STR ''java/lang/Throwable''"
definition this :: vname
where "this ≡ STR ''this''"
definition run :: mname
where "run ≡ STR ''run()V''"
definition start :: mname
where "start ≡ STR ''start()V''"
definition wait :: mname
where "wait ≡ STR ''wait()V''"
definition notify :: mname
where "notify ≡ STR ''notify()V''"
definition notifyAll :: mname
where "notifyAll ≡ STR ''notifyAll()V''"
definition join :: mname
where "join ≡ STR ''join()V''"
definition interrupt :: mname
where "interrupt ≡ STR ''interrupt()V''"
definition isInterrupted :: mname
where "isInterrupted ≡ STR ''isInterrupted()Z''"
definition hashcode :: mname
where "hashcode = STR ''hashCode()I''"
definition clone :: mname
where "clone = STR ''clone()Ljava/lang/Object;''"
definition print :: mname
where "print = STR ''~print(I)V''"
definition currentThread :: mname
where "currentThread = STR ''~Thread.currentThread()Ljava/lang/Thread;''"
definition interrupted :: mname
where "interrupted = STR ''~Thread.interrupted()Z''"
definition yield :: mname
where "yield = STR ''~Thread.yield()V''"
lemmas identifier_name_defs [code_unfold] =
this_def run_def start_def wait_def notify_def notifyAll_def join_def interrupt_def isInterrupted_def
hashcode_def clone_def print_def currentThread_def interrupted_def yield_def
lemma Object_Thread_Throwable_neq [simp]:
"Thread ≠ Object" "Object ≠ Thread"
"Object ≠ Throwable" "Throwable ≠ Object"
"Thread ≠ Throwable" "Throwable ≠ Thread"
by(auto simp add: Thread_def Object_def Throwable_def)
lemma synth_method_names_neq_aux:
"start ≠ wait" "start ≠ notify" "start ≠ notifyAll" "start ≠ join" "start ≠ interrupt" "start ≠ isInterrupted"
"start ≠ hashcode" "start ≠ clone" "start ≠ print" "start ≠ currentThread"
"start ≠ interrupted" "start ≠ yield" "start ≠ run"
"wait ≠ notify" "wait ≠ notifyAll" "wait ≠ join" "wait ≠ interrupt" "wait ≠ isInterrupted"
"wait ≠ hashcode" "wait ≠ clone" "wait ≠ print" "wait ≠ currentThread"
"wait ≠ interrupted" "wait ≠ yield" "wait ≠ run"
"notify ≠ notifyAll" "notify ≠ join" "notify ≠ interrupt" "notify ≠ isInterrupted"
"notify ≠ hashcode" "notify ≠ clone" "notify ≠ print" "notify ≠ currentThread"
"notify ≠ interrupted" "notify ≠ yield" "notify ≠ run"
"notifyAll ≠ join" "notifyAll ≠ interrupt" "notifyAll ≠ isInterrupted"
"notifyAll ≠ hashcode" "notifyAll ≠ clone" "notifyAll ≠ print" "notifyAll ≠ currentThread"
"notifyAll ≠ interrupted" "notifyAll ≠ yield" "notifyAll ≠ run"
"join ≠ interrupt" "join ≠ isInterrupted"
"join ≠ hashcode" "join ≠ clone" "join ≠ print" "join ≠ currentThread"
"join ≠ interrupted" "join ≠ yield" "join ≠ run"
"interrupt ≠ isInterrupted"
"interrupt ≠ hashcode" "interrupt ≠ clone" "interrupt ≠ print" "interrupt ≠ currentThread"
"interrupt ≠ interrupted" "interrupt ≠ yield" "interrupt ≠ run"
"isInterrupted ≠ hashcode" "isInterrupted ≠ clone" "isInterrupted ≠ print" "isInterrupted ≠ currentThread"
"isInterrupted ≠ interrupted" "isInterrupted ≠ yield" "isInterrupted ≠ run"
"hashcode ≠ clone" "hashcode ≠ print" "hashcode ≠ currentThread"
"hashcode ≠ interrupted" "hashcode ≠ yield" "hashcode ≠ run"
"clone ≠ print" "clone ≠ currentThread"
"clone ≠ interrupted" "clone ≠ yield" "clone ≠ run"
"print ≠ currentThread"
"print ≠ interrupted" "print ≠ yield" "print ≠ run"
"currentThread ≠ interrupted" "currentThread ≠ yield" "currentThread ≠ run"
"interrupted ≠ yield" "interrupted ≠ run"
"yield ≠ run"
by(simp_all add: identifier_name_defs)
lemmas synth_method_names_neq [simp] = synth_method_names_neq_aux synth_method_names_neq_aux[symmetric]
datatype ty
= Void
| Boolean
| Integer
| NT
| Class cname
| Array ty ("_⌊⌉" 95)
context
notes [[inductive_internals]]
begin
inductive is_refT :: "ty ⇒ bool" where
"is_refT NT"
| "is_refT (Class C)"
| "is_refT (A⌊⌉)"
declare is_refT.intros[iff]
end
lemmas refTE [consumes 1, case_names NT Class Array] = is_refT.cases
lemma not_refTE [consumes 1, case_names Void Boolean Integer]:
"⟦ ¬is_refT T; T = Void ⟹ P; T = Boolean ⟹ P; T = Integer ⟹ P ⟧ ⟹ P"
by (cases T, auto)
fun ground_type :: "ty ⇒ ty" where
"ground_type (Array T) = ground_type T"
| "ground_type T = T"
abbreviation is_NT_Array :: "ty ⇒ bool" where
"is_NT_Array T ≡ ground_type T = NT"
primrec the_Class :: "ty ⇒ cname"
where
"the_Class (Class C) = C"
primrec the_Array :: "ty ⇒ ty"
where
"the_Array (T⌊⌉) = T"
datatype htype =
Class_type "cname"
| Array_type "ty" "nat"
primrec ty_of_htype :: "htype ⇒ ty"
where
"ty_of_htype (Class_type C) = Class C"
| "ty_of_htype (Array_type T n) = Array T"
primrec alen_of_htype :: "htype ⇒ nat"
where
"alen_of_htype (Array_type T n) = n"
primrec class_type_of :: "htype ⇒ cname"
where
"class_type_of (Class_type C) = C"
| "class_type_of (Array_type T n) = Object"
fun class_type_of' :: "ty ⇒ cname option"
where
"class_type_of' (Class C) = ⌊C⌋"
| "class_type_of' (Array T) = ⌊Object⌋"
| "class_type_of' _ = None"
lemma rec_htype_is_case [simp]: "rec_htype = case_htype"
by(auto simp add: fun_eq_iff split: htype.split)
lemma ty_of_htype_eq_convs [simp]:
shows ty_of_htype_eq_Boolean: "ty_of_htype hT ≠ Boolean"
and ty_of_htype_eq_Void: "ty_of_htype hT ≠ Void"
and ty_of_htype_eq_Integer: "ty_of_htype hT ≠ Integer"
and ty_of_htype_eq_NT: "ty_of_htype hT ≠ NT"
and ty_of_htype_eq_Class: "ty_of_htype hT = Class C ⟷ hT = Class_type C"
and ty_of_htype_eq_Array: "ty_of_htype hT = Array T ⟷ (∃n. hT = Array_type T n)"
by(case_tac [!] hT) simp_all
lemma class_type_of_eq:
"class_type_of hT =
(case hT of Class_type C ⇒ C | Array_type T n ⇒ Object)"
by(simp split: htype.split)
lemma class_type_of'_ty_of_htype [simp]:
"class_type_of' (ty_of_htype hT) = ⌊class_type_of hT⌋"
by(cases hT) simp_all
fun is_Array :: "ty ⇒ bool"
where
"is_Array (Array T) = True"
| "is_Array _ = False"
lemma is_Array_conv [simp]: "is_Array T ⟷ (∃U. T = Array U)"
by(cases T) simp_all
fun is_Class :: "ty ⇒ bool"
where
"is_Class (Class C) = True"
| "is_Class _ = False"
lemma is_Class_conv [simp]: "is_Class T ⟷ (∃C. T = Class C)"
by(cases T) simp_all
subsection ‹Code generator setup›
code_pred is_refT .
end
Theory Decl
section ‹Class Declarations and Programs›
theory Decl
imports
Type
begin
type_synonym volatile = bool
record fmod =
volatile :: volatile
type_synonym fdecl = "vname × ty × fmod"
type_synonym 'm mdecl = "mname × ty list × ty × 'm"
type_synonym 'm mdecl' = "mname × ty list × ty × 'm option"
type_synonym 'm "class" = "cname × fdecl list × 'm mdecl' list"
type_synonym 'm cdecl = "cname × 'm class"
datatype
'm prog = Program "'m cdecl list"
translations
(type) "fdecl" <= (type) "String.literal × ty × fmod"
(type) "'c mdecl" <= (type) "String.literal × ty list × ty × 'c"
(type) "'c mdecl'" <= (type) "String.literal × ty list × ty × 'c option"
(type) "'c class" <= (type) "String.literal × fdecl list × ('c mdecl) list"
(type) "'c cdecl" <= (type) "String.literal × ('c class)"
notation (input) None ("Native")
primrec "classes" :: "'m prog ⇒ 'm cdecl list"
where
"classes (Program P) = P"
primrec "class" :: "'m prog ⇒ cname ⇀ 'm class"
where
"class (Program p) = map_of p"
locale prog =
fixes P :: "'m prog"
definition is_class :: "'m prog ⇒ cname ⇒ bool"
where
"is_class P C ≡ class P C ≠ None"
lemma finite_is_class: "finite {C. is_class P C}"
apply(cases P)
apply (unfold is_class_def)
apply (fold dom_def)
apply(simp add: finite_dom_map_of)
done
primrec is_type :: "'m prog ⇒ ty ⇒ bool"
where
is_type_void: "is_type P Void = True"
| is_type_bool: "is_type P Boolean = True"
| is_type_int: "is_type P Integer = True"
| is_type_nt: "is_type P NT = True"
| is_type_class: "is_type P (Class C) = is_class P C"
| is_type_array: "is_type P (A⌊⌉) = (case ground_type A of NT ⇒ False | Class C ⇒ is_class P C | _ ⇒ True)"
lemma is_type_ArrayD: "is_type P (T⌊⌉) ⟹ is_type P T"
by(induct T) auto
lemma is_type_ground_type:
"is_type P T ⟹ is_type P (ground_type T)"
by(induct T)(auto, metis is_type_ArrayD is_type_array)
abbreviation "types" :: "'m prog ⇒ ty set"
where "types P ≡ {T. is_type P T}"
abbreviation is_htype :: "'m prog ⇒ htype ⇒ bool"
where "is_htype P hT ≡ is_type P (ty_of_htype hT)"
subsection ‹Code generation›
lemma is_class_intros [code_pred_intro]:
"class P C ≠ None ⟹ is_class P C"
by(auto simp add: is_class_def)
code_pred
(modes: i ⇒ i ⇒ bool)
is_class
unfolding is_class_def by simp
declare is_class_def[code]
end
Theory TypeRel
section ‹Relations between Jinja Types›
theory TypeRel
imports
Decl
begin
subsection‹The subclass relations›
inductive subcls1 :: "'m prog ⇒ cname ⇒ cname ⇒ bool" ("_ ⊢ _ ≺⇧1 _" [71, 71, 71] 70)
for P :: "'m prog"
where subcls1I: "⟦ class P C = Some (D, rest); C ≠ Object ⟧ ⟹ P ⊢ C ≺⇧1 D"
abbreviation subcls :: "'m prog ⇒ cname ⇒ cname ⇒ bool" ("_ ⊢ _ ≼⇧* _" [71,71,71] 70)
where "P ⊢ C ≼⇧* D ≡ (subcls1 P)⇧*⇧* C D"
lemma subcls1D:
"P ⊢ C ≺⇧1 D ⟹ C ≠ Object ∧ (∃fs ms. class P C = Some (D,fs,ms))"
by(auto elim: subcls1.cases)
lemma Object_subcls1 [iff]: "¬ P ⊢ Object ≺⇧1 C"
by(simp add: subcls1.simps)
lemma Object_subcls_conv [iff]: "(P ⊢ Object ≼⇧* C) = (C = Object)"
by(auto elim: converse_rtranclpE)
lemma finite_subcls1: "finite {(C, D). P ⊢ C ≺⇧1 D}"
proof -
let ?A = "SIGMA C:{C. is_class P C}. {D. C≠Object ∧ fst (the (class P C))=D}"
have "finite ?A" by(rule finite_SigmaI [OF finite_is_class]) auto
also have "?A = {(C, D). P ⊢ C ≺⇧1 D}"
by(fastforce simp:is_class_def dest: subcls1D elim: subcls1I)
finally show ?thesis .
qed
lemma finite_subcls1':
"finite ({(D, C). P ⊢ C ≺⇧1 D})"
by(subst finite_converse[symmetric])
(simp add: converse_unfold finite_subcls1 del: finite_converse)
lemma subcls_is_class: "(subcls1 P)⇧+⇧+ C D ⟹ is_class P C"
by(auto elim: converse_tranclpE dest!: subcls1D simp add: is_class_def)
lemma subcls_is_class1: "⟦ P ⊢ C ≼⇧* D; is_class P D ⟧ ⟹ is_class P C"
by(auto elim: converse_rtranclpE dest!: subcls1D simp add: is_class_def)
subsection‹The subtype relations›
inductive widen :: "'m prog ⇒ ty ⇒ ty ⇒ bool" ("_ ⊢ _ ≤ _" [71,71,71] 70)
for P :: "'m prog"
where
widen_refl[iff]: "P ⊢ T ≤ T"
| widen_subcls: "P ⊢ C ≼⇧* D ⟹ P ⊢ Class C ≤ Class D"
| widen_null[iff]: "P ⊢ NT ≤ Class C"
| widen_null_array[iff]: "P ⊢ NT ≤ Array A"
| widen_array_object: "P ⊢ Array A ≤ Class Object"
| widen_array_array: "P ⊢ A ≤ B ⟹ P ⊢ Array A ≤ Array B"
abbreviation
widens :: "'m prog ⇒ ty list ⇒ ty list ⇒ bool" ("_ ⊢ _ [≤] _" [71,71,71] 70)
where
"P ⊢ Ts [≤] Ts' == list_all2 (widen P) Ts Ts'"
lemma [iff]: "(P ⊢ T ≤ Void) = (T = Void)"
by (auto elim: widen.cases)
lemma [iff]: "(P ⊢ T ≤ Boolean) = (T = Boolean)"
by (auto elim: widen.cases)
lemma [iff]: "(P ⊢ T ≤ Integer) = (T = Integer)"
by (auto elim: widen.cases)
lemma [iff]: "(P ⊢ Void ≤ T) = (T = Void)"
by (auto elim: widen.cases)
lemma [iff]: "(P ⊢ Boolean ≤ T) = (T = Boolean)"
by (auto elim: widen.cases)
lemma [iff]: "(P ⊢ Integer ≤ T) = (T = Integer)"
by (auto elim: widen.cases)
lemma Class_widen: "P ⊢ Class C ≤ T ⟹ ∃D. T = Class D"
by(erule widen.cases, auto)
lemma Array_Array_widen:
"P ⊢ Array T ≤ Array U ⟹ P ⊢ T ≤ U"
by(auto elim: widen.cases)
lemma widen_Array: "(P ⊢ T ≤ U⌊⌉) ⟷ (T = NT ∨ (∃V. T = V⌊⌉ ∧ P ⊢ V ≤ U))"
by(induct T)(auto dest: Array_Array_widen elim: widen.cases intro: widen_array_array)
lemma Array_widen: "P ⊢ Array A ≤ T ⟹ (∃B. T = Array B ∧ P ⊢ A ≤ B) ∨ T = Class Object"
by(auto elim: widen.cases)
lemma [iff]: "(P ⊢ T ≤ NT) = (T = NT)"
by(induct T)(auto dest:Class_widen Array_widen)
lemma Class_widen_Class [iff]: "(P ⊢ Class C ≤ Class D) = (P ⊢ C ≼⇧* D)"
by (auto elim: widen_subcls widen.cases)
lemma widen_Class: "(P ⊢ T ≤ Class C) = (T = NT ∨ (∃D. T = Class D ∧ P ⊢ D ≼⇧* C) ∨ (C = Object ∧ (∃A. T = Array A)))"
by(induct T)(auto dest: Array_widen intro: widen_array_object)
lemma NT_widen:
"P ⊢ NT ≤ T = (T = NT ∨ (∃C. T = Class C) ∨ (∃U. T = U⌊⌉))"
by(cases T) auto
lemma Class_widen2: "P ⊢ Class C ≤ T = (∃D. T = Class D ∧ P ⊢ C ≼⇧* D)"
by (cases T, auto elim: widen.cases)
lemma Object_widen: "P ⊢ Class Object ≤ T ⟹ T = Class Object"
by(cases T, auto elim: widen.cases)
lemma NT_Array_widen_Object:
"is_NT_Array T ⟹ P ⊢ T ≤ Class Object"
by(induct T, auto intro: widen_array_object)
lemma widen_trans[trans]:
assumes "P ⊢ S ≤ U" "P ⊢ U ≤ T"
shows "P ⊢ S ≤ T"
using assms
proof(induct arbitrary: T)
case (widen_refl T T') thus "P ⊢ T ≤ T'" .
next
case (widen_subcls C D T)
then obtain E where "T = Class E" by (blast dest: Class_widen)
with widen_subcls show "P ⊢ Class C ≤ T" by (auto elim: rtrancl_trans)
next
case (widen_null C RT)
then obtain D where "RT = Class D" by (blast dest: Class_widen)
thus "P ⊢ NT ≤ RT" by auto
next
case widen_null_array thus ?case by(auto dest: Array_widen)
next
case (widen_array_object A T)
hence "T = Class Object" by(rule Object_widen)
with widen_array_object show "P ⊢ A⌊⌉ ≤ T"
by(auto intro: widen.widen_array_object)
next
case widen_array_array thus ?case
by(auto dest!: Array_widen intro: widen.widen_array_array widen_array_object)
qed
lemma widens_trans: "⟦P ⊢ Ss [≤] Ts; P ⊢ Ts [≤] Us⟧ ⟹ P ⊢ Ss [≤] Us"
by (rule list_all2_trans)(rule widen_trans)
lemma class_type_of'_widenD:
"class_type_of' T = ⌊C⌋ ⟹ P ⊢ T ≤ Class C"
by(cases T)(auto intro: widen_array_object)
lemma widen_is_class_type_of:
assumes "class_type_of' T = ⌊C⌋" "P ⊢ T' ≤ T" "T' ≠ NT"
obtains C' where "class_type_of' T' = ⌊C'⌋" "P ⊢ C' ≼⇧* C"
using assms by(cases T)(auto simp add: widen_Class widen_Array)
lemma widens_refl: "P ⊢ Ts [≤] Ts"
by(rule list_all2_refl[OF widen_refl])
lemma widen_append1:
"P ⊢ (xs @ ys) [≤] Ts = (∃Ts1 Ts2. Ts = Ts1 @ Ts2 ∧ length xs = length Ts1 ∧ length ys = length Ts2 ∧ P ⊢ xs [≤] Ts1 ∧ P ⊢ ys [≤] Ts2)"
unfolding list_all2_append1 by fastforce
lemmas widens_Cons [iff] = list_all2_Cons1 [of "widen P"] for P
lemma widens_lengthD:
"P ⊢ xs [≤] ys ⟹ length xs = length ys"
by(rule list_all2_lengthD)
lemma widen_refT: "⟦ is_refT T; P ⊢ U ≤ T ⟧ ⟹ is_refT U"
by(erule refTE)(auto simp add: widen_Class widen_Array)
lemma refT_widen: "⟦ is_refT T; P ⊢ T ≤ U ⟧ ⟹ is_refT U"
by(erule widen.cases) auto
inductive is_lub :: "'m prog ⇒ ty ⇒ ty ⇒ ty ⇒ bool" ("_ ⊢ lub'((_,/ _)') = _" [51,51,51,51] 50)
for P :: "'m prog" and U :: ty and V :: ty and T :: ty
where
"⟦ P ⊢ U ≤ T; P ⊢ V ≤ T;
⋀T'. ⟦ P ⊢ U ≤ T'; P ⊢ V ≤ T' ⟧ ⟹ P ⊢ T ≤ T' ⟧
⟹ P ⊢ lub(U, V) = T"
lemma is_lub_upper:
"P ⊢ lub(U, V) = T ⟹ P ⊢ U ≤ T ∧ P ⊢ V ≤ T"
by(auto elim: is_lub.cases)
lemma is_lub_least:
"⟦ P ⊢ lub(U, V) = T; P ⊢ U ≤ T'; P ⊢ V ≤ T' ⟧ ⟹ P ⊢ T ≤ T'"
by(auto elim: is_lub.cases)
lemma is_lub_Void [iff]:
"P ⊢ lub(Void, Void) = T ⟷ T = Void"
by(auto intro: is_lub.intros elim: is_lub.cases)
lemma is_lubI [code_pred_intro]:
"⟦P ⊢ U ≤ T; P ⊢ V ≤ T; ∀T'. P ⊢ U ≤ T' ⟶ P ⊢ V ≤ T' ⟶ P ⊢ T ≤ T'⟧ ⟹ P ⊢ lub(U, V) = T"
by(blast intro: is_lub.intros)
subsection‹Method lookup›
inductive Methods :: "'m prog ⇒ cname ⇒ (mname ⇀ (ty list × ty × 'm option) × cname) ⇒ bool"
("_ ⊢ _ sees'_methods _" [51,51,51] 50)
for P :: "'m prog"
where
sees_methods_Object:
"⟦ class P Object = Some(D,fs,ms); Mm = map_option (λm. (m,Object)) ∘ map_of ms ⟧
⟹ P ⊢ Object sees_methods Mm"
| sees_methods_rec:
"⟦ class P C = Some(D,fs,ms); C ≠ Object; P ⊢ D sees_methods Mm;
Mm' = Mm ++ (map_option (λm. (m,C)) ∘ map_of ms) ⟧
⟹ P ⊢ C sees_methods Mm'"
lemma sees_methods_fun:
assumes "P ⊢ C sees_methods Mm"
shows "P ⊢ C sees_methods Mm' ⟹ Mm' = Mm"
using assms
proof(induction arbitrary: Mm')
case sees_methods_Object thus ?case by(auto elim: Methods.cases)
next
case (sees_methods_rec C D fs ms Dres Cres Cres')
from ‹P ⊢ C sees_methods Cres'› ‹C ≠ Object› ‹class P C = ⌊(D, fs, ms)⌋›
obtain Dres' where Dmethods': "P ⊢ D sees_methods Dres'"
and Cres': "Cres' = Dres' ++ (map_option (λm. (m,C)) ∘ map_of ms)"
by cases auto
from sees_methods_rec.IH[OF Dmethods'] ‹Cres = Dres ++ (map_option (λm. (m,C)) ∘ map_of ms)› Cres'
show ?case by simp
qed
lemma visible_methods_exist:
"P ⊢ C sees_methods Mm ⟹ Mm M = Some(m,D) ⟹
(∃D' fs ms. class P D = Some(D',fs,ms) ∧ map_of ms M = Some m)"
by(induct rule:Methods.induct) auto
lemma sees_methods_decl_above:
assumes "P ⊢ C sees_methods Mm"
shows "Mm M = Some(m,D) ⟹ P ⊢ C ≼⇧* D"
using assms
by induct(auto elim: converse_rtranclp_into_rtranclp[where r = "subcls1 P", OF subcls1I])
lemma sees_methods_idemp:
assumes "P ⊢ C sees_methods Mm" and "Mm M = Some(m,D)"
shows "∃Mm'. (P ⊢ D sees_methods Mm') ∧ Mm' M = Some(m,D)"
using assms
by(induct arbitrary: m D)(fastforce dest: Methods.intros)+
lemma sees_methods_decl_mono:
assumes sub: "P ⊢ C' ≼⇧* C" and "P ⊢ C sees_methods Mm"
shows "∃Mm' Mm⇩2. P ⊢ C' sees_methods Mm' ∧ Mm' = Mm ++ Mm⇩2 ∧ (∀M m D. Mm⇩2 M = Some(m,D) ⟶ P ⊢ D ≼⇧* C)"
(is "∃Mm' Mm2. ?Q C' C Mm' Mm2")
using assms
proof (induction rule: converse_rtranclp_induct)
case base
hence "?Q C C Mm Map.empty" by simp
thus "∃Mm' Mm2. ?Q C C Mm' Mm2" by blast
next
case (step C'' C')
note sub1 = ‹P ⊢ C'' ≺⇧1 C'› and sub = ‹P ⊢ C' ≼⇧* C›
and Csees = ‹P ⊢ C sees_methods Mm›
from step.IH[OF Csees] obtain Mm' Mm2 where C'sees: "P ⊢ C' sees_methods Mm'"
and Mm': "Mm' = Mm ++ Mm2"
and subC: "∀M m D. Mm2 M = Some(m,D) ⟶ P ⊢ D ≼⇧* C" by blast
obtain fs ms where "class": "class P C'' = Some(C',fs,ms)" "C'' ≠ Object"
using subcls1D[OF sub1] by blast
let ?Mm3 = "map_option (λm. (m,C'')) ∘ map_of ms"
have "P ⊢ C'' sees_methods (Mm ++ Mm2) ++ ?Mm3"
using sees_methods_rec[OF "class" C'sees refl] Mm' by simp
hence "?Q C'' C ((Mm ++ Mm2) ++ ?Mm3) (Mm2++?Mm3)"
using converse_rtranclp_into_rtranclp[OF sub1 sub]
by simp (simp add:map_add_def subC split:option.split)
thus "∃Mm' Mm2. ?Q C'' C Mm' Mm2" by blast
qed
definition Method :: "'m prog ⇒ cname ⇒ mname ⇒ ty list ⇒ ty ⇒ 'm option ⇒ cname ⇒ bool"
("_ ⊢ _ sees _: _→_ = _ in _" [51,51,51,51,51,51,51] 50)
where
"P ⊢ C sees M: Ts→T = m in D ≡
∃Mm. P ⊢ C sees_methods Mm ∧ Mm M = Some((Ts,T,m),D)"
text ‹
Output translation to replace @{term "None"} with its notation ‹Native›
when used as method body in @{term "Method"}.
›
abbreviation (output)
Method_native :: "'m prog ⇒ cname ⇒ mname ⇒ ty list ⇒ ty ⇒ cname ⇒ bool"
("_ ⊢ _ sees _: _→_ = Native in _" [51,51,51,51,51,51] 50)
where "Method_native P C M Ts T D ≡ Method P C M Ts T Native D"
definition has_method :: "'m prog ⇒ cname ⇒ mname ⇒ bool" ("_ ⊢ _ has _" [51,0,51] 50)
where
"P ⊢ C has M ≡ ∃Ts T m D. P ⊢ C sees M:Ts→T = m in D"
lemma has_methodI:
"P ⊢ C sees M:Ts→T = m in D ⟹ P ⊢ C has M"
by (unfold has_method_def) blast
lemma sees_method_fun:
"⟦P ⊢ C sees M:TS→T = m in D; P ⊢ C sees M:TS'→T' = m' in D' ⟧
⟹ TS' = TS ∧ T' = T ∧ m' = m ∧ D' = D"
by(fastforce dest: sees_methods_fun simp:Method_def)
lemma sees_method_decl_above:
"P ⊢ C sees M:Ts→T = m in D ⟹ P ⊢ C ≼⇧* D"
by(clarsimp simp:Method_def sees_methods_decl_above)
lemma visible_method_exists:
"P ⊢ C sees M:Ts→T = m in D ⟹
∃D' fs ms. class P D = Some(D',fs,ms) ∧ map_of ms M = Some(Ts,T,m)"
by(fastforce simp:Method_def dest!: visible_methods_exist)
lemma sees_method_idemp:
"P ⊢ C sees M:Ts→T=m in D ⟹ P ⊢ D sees M:Ts→T=m in D"
by(fastforce simp: Method_def intro:sees_methods_idemp)
lemma sees_method_decl_mono:
"⟦ P ⊢ C' ≼⇧* C; P ⊢ C sees M:Ts→T = m in D;
P ⊢ C' sees M:Ts'→T' = m' in D' ⟧ ⟹ P ⊢ D' ≼⇧* D"
apply(frule sees_method_decl_above)
apply(unfold Method_def)
apply clarsimp
apply(drule (1) sees_methods_decl_mono)
apply clarsimp
apply(drule (1) sees_methods_fun)
apply clarsimp
apply(blast intro:rtranclp_trans)
done
lemma sees_method_is_class:
"P ⊢ C sees M:Ts→T = m in D ⟹ is_class P C"
by (auto simp add: is_class_def Method_def elim: Methods.cases)
subsection‹Field lookup›
inductive Fields :: "'m prog ⇒ cname ⇒ ((vname × cname) × (ty × fmod)) list ⇒ bool"
("_ ⊢ _ has'_fields _" [51,51,51] 50)
for P :: "'m prog"
where
has_fields_rec:
"⟦ class P C = Some(D,fs,ms); C ≠ Object; P ⊢ D has_fields FDTs;
FDTs' = map (λ(F,Tm). ((F,C),Tm)) fs @ FDTs ⟧
⟹ P ⊢ C has_fields FDTs'"
| has_fields_Object:
"⟦ class P Object = Some(D,fs,ms); FDTs = map (λ(F,T). ((F,Object),T)) fs ⟧
⟹ P ⊢ Object has_fields FDTs"
lemma has_fields_fun:
assumes "P ⊢ C has_fields FDTs" and "P ⊢ C has_fields FDTs'"
shows "FDTs' = FDTs"
using assms
proof(induction arbitrary: FDTs')
case has_fields_Object thus ?case by(auto elim: Fields.cases)
next
case (has_fields_rec C D fs ms Dres Cres Cres')
from ‹P ⊢ C has_fields Cres'› ‹C ≠ Object› ‹class P C = Some (D, fs, ms)›
obtain Dres' where DFields': "P ⊢ D has_fields Dres'"
and Cres': "Cres' = map (λ(F,Tm). ((F,C),Tm)) fs @ Dres'"
by cases auto
from has_fields_rec.IH[OF DFields'] ‹Cres = map (λ(F,Tm). ((F,C),Tm)) fs @ Dres› Cres'
show ?case by simp
qed
lemma all_fields_in_has_fields:
assumes "P ⊢ C has_fields FDTs"
and "P ⊢ C ≼⇧* D" "class P D = Some(D',fs,ms)" "(F,Tm) ∈ set fs"
shows "((F,D),Tm) ∈ set FDTs"
using assms
by induct (auto 4 3 elim: converse_rtranclpE dest: subcls1D)
lemma has_fields_decl_above:
assumes "P ⊢ C has_fields FDTs" "((F,D),Tm) ∈ set FDTs"
shows "P ⊢ C ≼⇧* D"
using assms
by induct (auto intro: converse_rtranclp_into_rtranclp subcls1I)
lemma subcls_notin_has_fields:
assumes "P ⊢ C has_fields FDTs" "((F,D),Tm) ∈ set FDTs"
shows "¬ (subcls1 P)⇧+⇧+ D C"
using assms apply(induct)
prefer 2 apply(fastforce dest: tranclpD)
apply clarsimp
apply(erule disjE)
apply(clarsimp simp add:image_def)
apply(drule tranclpD)
apply clarify
apply(frule subcls1D)
apply(fastforce dest:tranclpD all_fields_in_has_fields)
apply(blast dest:subcls1I tranclp.trancl_into_trancl)
done
lemma has_fields_mono_lem:
assumes "P ⊢ D ≼⇧* C" "P ⊢ C has_fields FDTs"
shows "∃pre. P ⊢ D has_fields pre@FDTs ∧ dom(map_of pre) ∩ dom(map_of FDTs) = {}"
using assms
apply(induct rule:converse_rtranclp_induct)
apply(rule_tac x = "[]" in exI)
apply simp
apply clarsimp
apply(rename_tac D' D pre)
apply(subgoal_tac "(subcls1 P)^++ D' C")
prefer 2 apply(erule (1) rtranclp_into_tranclp2)
apply(drule subcls1D)
apply clarsimp
apply(rename_tac fs ms)
apply(drule (2) has_fields_rec)
apply(rule refl)
apply(rule_tac x = "map (λ(F,Tm). ((F,D'),Tm)) fs @ pre" in exI)
apply simp
apply(simp add:Int_Un_distrib2)
apply(rule equals0I)
apply(auto dest: subcls_notin_has_fields simp:dom_map_of_conv_image_fst image_def)
done
lemma has_fields_is_class:
"P ⊢ C has_fields FDTs ⟹ is_class P C"
by (auto simp add: is_class_def elim: Fields.cases)
lemma Object_has_fields_Object:
assumes "P ⊢ Object has_fields FDTs"
shows "snd ` fst ` set FDTs ⊆ {Object}"
using assms by cases auto
definition
has_field :: "'m prog ⇒ cname ⇒ vname ⇒ ty ⇒ fmod ⇒ cname ⇒ bool"
("_ ⊢ _ has _:_ '(_') in _" [51,51,51,51,51,51] 50)
where
"P ⊢ C has F:T (fm) in D ≡
∃FDTs. P ⊢ C has_fields FDTs ∧ map_of FDTs (F,D) = Some (T, fm)"
lemma has_field_mono:
"⟦ P ⊢ C has F:T (fm) in D; P ⊢ C' ≼⇧* C ⟧ ⟹ P ⊢ C' has F:T (fm) in D"
by(fastforce simp:has_field_def map_add_def dest: has_fields_mono_lem)
lemma has_field_is_class:
"P ⊢ C has M:T (fm) in D ⟹ is_class P C"
by (auto simp add: is_class_def has_field_def elim: Fields.cases)
lemma has_field_decl_above:
"P ⊢ C has F:T (fm) in D ⟹ P ⊢ C ≼⇧* D"
unfolding has_field_def
by(auto dest: map_of_SomeD has_fields_decl_above)
lemma has_field_fun:
"⟦P ⊢ C has F:T (fm) in D; P ⊢ C has F:T' (fm') in D⟧ ⟹ T' = T ∧ fm = fm'"
by(auto simp:has_field_def dest:has_fields_fun)
definition
sees_field :: "'m prog ⇒ cname ⇒ vname ⇒ ty ⇒ fmod ⇒ cname ⇒ bool"
("_ ⊢ _ sees _:_ '(_') in _" [51,51,51,51,51,51] 50)
where
"P ⊢ C sees F:T (fm) in D ≡
∃FDTs. P ⊢ C has_fields FDTs ∧
map_of (map (λ((F,D),Tm). (F,(D,Tm))) FDTs) F = Some(D,T,fm)"
lemma map_of_remap_SomeD:
"map_of (map (λ((k,k'),x). (k,(k',x))) t) k = Some (k',x) ⟹ map_of t (k, k') = Some x"
by (induct t) (auto simp:fun_upd_apply split: if_split_asm)
lemma has_visible_field:
"P ⊢ C sees F:T (fm) in D ⟹ P ⊢ C has F:T (fm) in D"
by(auto simp add:has_field_def sees_field_def map_of_remap_SomeD)
lemma sees_field_fun:
"⟦P ⊢ C sees F:T (fm) in D; P ⊢ C sees F:T' (fm') in D'⟧ ⟹ T' = T ∧ D' = D ∧ fm = fm'"
by(fastforce simp:sees_field_def dest:has_fields_fun)
lemma sees_field_decl_above:
"P ⊢ C sees F:T (fm) in D ⟹ P ⊢ C ≼⇧* D"
by(clarsimp simp add: sees_field_def)
(blast intro: has_fields_decl_above map_of_SomeD map_of_remap_SomeD)
lemma sees_field_idemp:
assumes "P ⊢ C sees F:T (fm) in D"
shows "P ⊢ D sees F:T (fm) in D"
proof -
from assms obtain FDTs where has: "P ⊢ C has_fields FDTs"
and F: "map_of (map (λ((F, D), Tm). (F, D, Tm)) FDTs) F = ⌊(D, T, fm)⌋"
unfolding sees_field_def by blast
thus ?thesis
proof induct
case has_fields_rec thus ?case unfolding sees_field_def
by(auto)(fastforce dest: map_of_SomeD intro!: exI intro: Fields.has_fields_rec)
next
case has_fields_Object thus ?case unfolding sees_field_def
by(fastforce dest: map_of_SomeD intro: Fields.has_fields_Object intro!: exI)
qed
qed
subsection "Functional lookup"
definition "method" :: "'m prog ⇒ cname ⇒ mname ⇒ cname × ty list × ty × 'm option"
where "method P C M ≡ THE (D,Ts,T,m). P ⊢ C sees M:Ts → T = m in D"
definition field :: "'m prog ⇒ cname ⇒ vname ⇒ cname × ty × fmod"
where "field P C F ≡ THE (D,T,fm). P ⊢ C sees F:T (fm) in D"
definition fields :: "'m prog ⇒ cname ⇒ ((vname × cname) × (ty × fmod)) list"
where "fields P C ≡ THE FDTs. P ⊢ C has_fields FDTs"
lemma [simp]: "P ⊢ C has_fields FDTs ⟹ fields P C = FDTs"
by (unfold fields_def) (auto dest: has_fields_fun)
lemma field_def2 [simp]: "P ⊢ C sees F:T (fm) in D ⟹ field P C F = (D,T,fm)"
by (unfold field_def) (auto dest: sees_field_fun)
lemma method_def2 [simp]: "P ⊢ C sees M: Ts→T = m in D ⟹ method P C M = (D,Ts,T,m)"
by (unfold method_def) (auto dest: sees_method_fun)
lemma has_fields_b_fields:
"P ⊢ C has_fields FDTs ⟹ fields P C = FDTs"
unfolding fields_def
by (blast intro: the_equality has_fields_fun)
lemma has_field_map_of_fields [simp]:
"P ⊢ C has F:T (fm) in D ⟹ map_of (fields P C) (F, D) = ⌊(T, fm)⌋"
by(auto simp add: has_field_def)
subsection ‹Code generation›
text ‹New introduction rules for subcls1›
code_pred
(modes: i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ o ⇒ bool)
subcls1
.
text ‹
Introduce proper constant ‹subcls'› for @{term "subcls"}
and generate executable equation for ‹subcls'›
›
definition subcls' where "subcls' = subcls"
code_pred
(modes: i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ o ⇒ bool)
[inductify]
subcls'
.
lemma subcls_conv_subcls' [code_unfold]:
"(subcls1 P)^** = subcls' P"
by(simp add: subcls'_def)
text ‹
Change rule @{thm widen_array_object} such that predicate compiler
tests on class @{term Object} first. Otherwise ‹widen_i_o_i› never terminates.
›
lemma widen_array_object_code:
"C = Object ⟹ P ⊢ Array A ≤ Class C"
by(auto intro: widen.intros)
lemmas [code_pred_intro] =
widen_refl widen_subcls widen_null widen_null_array widen_array_object_code widen_array_array
code_pred
(modes: i ⇒ i ⇒ i ⇒ bool)
widen
by(erule widen.cases) auto
text ‹
Readjust the code equations for @{term widen} such that @{term widen_i_i_i} is guaranteed to
contain @{term "()"} at most once (even in the code representation!). This is important
for the scheduler and the small-step semantics because of the weaker code equations
for @{term "the"}.
A similar problem cannot hit the subclass relation because, for acyclic subclass hierarchies,
the paths in the hieararchy are unique and cycle-free.
›
definition widen_i_i_i' where "widen_i_i_i' = widen_i_i_i"
declare widen.equation [code del]
lemmas widen_i_i_i'_equation [code] = widen.equation[folded widen_i_i_i'_def]
lemma widen_i_i_i_code [code]:
"widen_i_i_i P T T' = (if P ⊢ T ≤ T' then Predicate.single () else bot)"
by(auto intro!: pred_eqI intro: widen_i_i_iI elim: widen_i_i_iE)
code_pred
(modes: i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ o ⇒ bool)
Methods
.
code_pred
(modes: i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ o ⇒ o ⇒ bool, i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ o ⇒ i ⇒ bool)
[inductify]
Method
.
code_pred
(modes: i ⇒ i ⇒ i ⇒ bool)
[inductify]
has_method
.
declare fun_upd_def [code_pred_inline]
code_pred
(modes: i ⇒ i ⇒ o ⇒ bool)
Fields
.
code_pred
(modes: i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ i ⇒ bool)
[inductify, skip_proof]
has_field
.
code_pred
(modes: i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ o ⇒ bool, i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ i ⇒ bool)
[inductify, skip_proof]
sees_field
.
lemma eval_Method_i_i_i_o_o_o_o_conv:
"Predicate.eval (Method_i_i_i_o_o_o_o P C M) = (λ(Ts, T, m, D). P ⊢ C sees M:Ts→T=m in D)"
by(auto intro: Method_i_i_i_o_o_o_oI elim: Method_i_i_i_o_o_o_oE intro!: ext)
lemma method_code [code]:
"method P C M =
Predicate.the (Predicate.bind (Method_i_i_i_o_o_o_o P C M) (λ(Ts, T, m, D). Predicate.single (D, Ts, T, m)))"
apply (rule sym, rule the_eqI)
apply (simp add: method_def eval_Method_i_i_i_o_o_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: Sup_fun_def Sup_bool_def fun_eq_iff)
done
lemma eval_sees_field_i_i_i_o_o_o_conv:
"Predicate.eval (sees_field_i_i_i_o_o_o P C F) = (λ(T, fm, D). P ⊢ C sees F:T (fm) in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_o_oI elim: sees_field_i_i_i_o_o_oE)
lemma eval_sees_field_i_i_i_o_i_conv:
"Predicate.eval (sees_field_i_i_i_o_o_i P C F D) = (λ(T, fm). P ⊢ C sees F:T (fm) in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_o_iI elim: sees_field_i_i_i_o_o_iE)
lemma field_code [code]:
"field P C F = Predicate.the (Predicate.bind (sees_field_i_i_i_o_o_o P C F) (λ(T, fm, D). Predicate.single (D, T, fm)))"
apply (rule sym, rule the_eqI)
apply (simp add: field_def eval_sees_field_i_i_i_o_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: Sup_fun_def Sup_bool_def fun_eq_iff)
done
lemma eval_Fields_conv:
"Predicate.eval (Fields_i_i_o P C) = (λFDTs. P ⊢ C has_fields FDTs)"
by(auto intro: Fields_i_i_oI elim: Fields_i_i_oE intro!: ext)
lemma fields_code [code]:
"fields P C = Predicate.the (Fields_i_i_o P C)"
by(simp add: fields_def Predicate.the_def eval_Fields_conv)
code_identifier
code_module TypeRel ⇀
(SML) TypeRel and (Haskell) TypeRel and (OCaml) TypeRel
| code_module Decl ⇀
(SML) TypeRel and (Haskell) TypeRel and (OCaml) TypeRel
end
Theory Value
section ‹Jinja Values›
theory Value
imports
TypeRel
"HOL-Library.Word"
begin
no_notation floor ("⌊_⌋")
type_synonym word32 = "32 word"
datatype 'addr val
= Unit
| Null
| Bool bool
| Intg word32
| Addr 'addr
primrec default_val :: "ty ⇒ 'addr val"
where
"default_val Void = Unit"
| "default_val Boolean = Bool False"
| "default_val Integer = Intg 0"
| "default_val NT = Null"
| "default_val (Class C) = Null"
| "default_val (Array A) = Null"
lemma default_val_not_Addr: "default_val T ≠ Addr a"
by(cases T)(simp_all)
lemma Addr_not_default_val: "Addr a ≠ default_val T"
by(cases T)(simp_all)
primrec the_Intg :: "'addr val ⇒ word32"
where
"the_Intg (Intg i) = i"
primrec the_Addr :: "'addr val ⇒ 'addr"
where
"the_Addr (Addr a) = a"
fun is_Addr :: "'addr val ⇒ bool"
where
"is_Addr (Addr a) = True"
| "is_Addr _ = False"
lemma is_AddrE [elim!]:
"⟦ is_Addr v; ⋀a. v = Addr a ⟹ thesis ⟧ ⟹ thesis"
by(cases v, auto)
fun is_Intg :: "'addr val ⇒ bool"
where
"is_Intg (Intg i) = True"
| "is_Intg _ = False"
lemma is_IntgE [elim!]:
"⟦ is_Intg v; ⋀i. v = Intg i ⟹ thesis ⟧ ⟹ thesis"
by(cases v, auto)
fun is_Bool :: "'addr val ⇒ bool"
where
"is_Bool (Bool b) = True"
| "is_Bool _ = False"
lemma is_BoolE [elim!]:
"⟦ is_Bool v; ⋀a. v = Bool a ⟹ thesis ⟧ ⟹ thesis"
by(cases v, auto)
definition is_Ref :: "'addr val ⇒ bool"
where "is_Ref v ≡ v = Null ∨ is_Addr v"
lemma is_Ref_def2:
"is_Ref v = (v = Null ∨ (∃a. v = Addr a))"
by (cases v) (auto simp add: is_Ref_def)
lemma [iff]: "is_Ref Null" by (simp add: is_Ref_def2)
definition undefined_value :: "'addr val" where "undefined_value = Unit"
lemma undefined_value_not_Addr:
"undefined_value ≠ Addr a" "Addr a ≠ undefined_value"
by(simp_all add: undefined_value_def)
class addr =
fixes hash_addr :: "'a ⇒ int"
and monitor_finfun_to_list :: "('a ⇒f nat) ⇒ 'a list"
assumes "set (monitor_finfun_to_list f) = Collect (($) (finfun_dom f))"
locale addr_base =
fixes addr2thread_id :: "'addr ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
end
Theory Exceptions
section ‹Exceptions›
theory Exceptions
imports
Value
begin
definition NullPointer :: cname
where [code_unfold]: "NullPointer = STR ''java/lang/NullPointerException''"
definition ClassCast :: cname
where [code_unfold]: "ClassCast = STR ''java/lang/ClassCastException''"
definition OutOfMemory :: cname
where [code_unfold]: "OutOfMemory = STR ''java/lang/OutOfMemoryError''"
definition ArrayIndexOutOfBounds :: cname
where [code_unfold]: "ArrayIndexOutOfBounds = STR ''java/lang/ArrayIndexOutOfBoundsException''"
definition ArrayStore :: cname
where [code_unfold]: "ArrayStore = STR ''java/lang/ArrayStoreException''"
definition NegativeArraySize :: cname
where [code_unfold]: "NegativeArraySize = STR ''java/lang/NegativeArraySizeException''"
definition ArithmeticException :: cname
where [code_unfold]: "ArithmeticException = STR ''java/lang/ArithmeticException''"
definition IllegalMonitorState :: cname
where [code_unfold]: "IllegalMonitorState = STR ''java/lang/IllegalMonitorStateException''"
definition IllegalThreadState :: cname
where [code_unfold]: "IllegalThreadState = STR ''java/lang/IllegalThreadStateException''"
definition InterruptedException :: cname
where [code_unfold]: "InterruptedException = STR ''java/lang/InterruptedException''"
definition sys_xcpts_list :: "cname list"
where
"sys_xcpts_list =
[NullPointer, ClassCast, OutOfMemory, ArrayIndexOutOfBounds, ArrayStore, NegativeArraySize, ArithmeticException,
IllegalMonitorState, IllegalThreadState, InterruptedException]"
definition sys_xcpts :: "cname set"
where [code_unfold]: "sys_xcpts = set sys_xcpts_list"
definition wf_syscls :: "'m prog ⇒ bool"
where "wf_syscls P ≡ (∀C ∈ {Object, Throwable, Thread}. is_class P C) ∧ (∀C ∈ sys_xcpts. P ⊢ C ≼⇧* Throwable)"
subsection "System exceptions"
lemma [simp]:
"NullPointer ∈ sys_xcpts ∧
OutOfMemory ∈ sys_xcpts ∧
ClassCast ∈ sys_xcpts ∧
ArrayIndexOutOfBounds ∈ sys_xcpts ∧
ArrayStore ∈ sys_xcpts ∧
NegativeArraySize ∈ sys_xcpts ∧
IllegalMonitorState ∈ sys_xcpts ∧
IllegalThreadState ∈ sys_xcpts ∧
InterruptedException ∈ sys_xcpts ∧
ArithmeticException ∈ sys_xcpts"
by(simp add: sys_xcpts_def sys_xcpts_list_def)
lemma sys_xcpts_cases [consumes 1, cases set]:
"⟦ C ∈ sys_xcpts; P NullPointer; P OutOfMemory; P ClassCast;
P ArrayIndexOutOfBounds; P ArrayStore; P NegativeArraySize;
P ArithmeticException;
P IllegalMonitorState; P IllegalThreadState; P InterruptedException ⟧
⟹ P C"
by (auto simp add: sys_xcpts_def sys_xcpts_list_def)
lemma OutOfMemory_not_Object[simp]: "OutOfMemory ≠ Object"
by(simp add: OutOfMemory_def Object_def)
lemma ClassCast_not_Object[simp]: "ClassCast ≠ Object"
by(simp add: ClassCast_def Object_def)
lemma NullPointer_not_Object[simp]: "NullPointer ≠ Object"
by(simp add: NullPointer_def Object_def)
lemma ArrayIndexOutOfBounds_not_Object[simp]: "ArrayIndexOutOfBounds ≠ Object"
by(simp add: ArrayIndexOutOfBounds_def Object_def)
lemma ArrayStore_not_Object[simp]: "ArrayStore ≠ Object"
by(simp add: ArrayStore_def Object_def)
lemma NegativeArraySize_not_Object[simp]: "NegativeArraySize ≠ Object"
by(simp add: NegativeArraySize_def Object_def)
lemma ArithmeticException_not_Object[simp]: "ArithmeticException ≠ Object"
by(simp add: ArithmeticException_def Object_def)
lemma IllegalMonitorState_not_Object[simp]: "IllegalMonitorState ≠ Object"
by(simp add: IllegalMonitorState_def Object_def)
lemma IllegalThreadState_not_Object[simp]: "IllegalThreadState ≠ Object"
by(simp add: IllegalThreadState_def Object_def)
lemma InterruptedException_not_Object[simp]: "InterruptedException ≠ Object"
by(simp add: InterruptedException_def Object_def)
lemma sys_xcpts_neqs_aux:
"NullPointer ≠ ClassCast" "NullPointer ≠ OutOfMemory" "NullPointer ≠ ArrayIndexOutOfBounds"
"NullPointer ≠ ArrayStore" "NullPointer ≠ NegativeArraySize" "NullPointer ≠ IllegalMonitorState"
"NullPointer ≠ IllegalThreadState" "NullPointer ≠ InterruptedException" "NullPointer ≠ ArithmeticException"
"ClassCast ≠ OutOfMemory" "ClassCast ≠ ArrayIndexOutOfBounds"
"ClassCast ≠ ArrayStore" "ClassCast ≠ NegativeArraySize" "ClassCast ≠ IllegalMonitorState"
"ClassCast ≠ IllegalThreadState" "ClassCast ≠ InterruptedException" "ClassCast ≠ ArithmeticException"
"OutOfMemory ≠ ArrayIndexOutOfBounds"
"OutOfMemory ≠ ArrayStore" "OutOfMemory ≠ NegativeArraySize" "OutOfMemory ≠ IllegalMonitorState"
"OutOfMemory ≠ IllegalThreadState" "OutOfMemory ≠ InterruptedException"
"OutOfMemory ≠ ArithmeticException"
"ArrayIndexOutOfBounds ≠ ArrayStore" "ArrayIndexOutOfBounds ≠ NegativeArraySize" "ArrayIndexOutOfBounds ≠ IllegalMonitorState"
"ArrayIndexOutOfBounds ≠ IllegalThreadState" "ArrayIndexOutOfBounds ≠ InterruptedException" "ArrayIndexOutOfBounds ≠ ArithmeticException"
"ArrayStore ≠ NegativeArraySize" "ArrayStore ≠ IllegalMonitorState"
"ArrayStore ≠ IllegalThreadState" "ArrayStore ≠ InterruptedException"
"ArrayStore ≠ ArithmeticException"
"NegativeArraySize ≠ IllegalMonitorState"
"NegativeArraySize ≠ IllegalThreadState" "NegativeArraySize ≠ InterruptedException"
"NegativeArraySize ≠ ArithmeticException"
"IllegalMonitorState ≠ IllegalThreadState" "IllegalMonitorState ≠ InterruptedException"
"IllegalMonitorState ≠ ArithmeticException"
"IllegalThreadState ≠ InterruptedException"
"IllegalThreadState ≠ ArithmeticException"
"InterruptedException ≠ ArithmeticException"
by(simp_all add: NullPointer_def ClassCast_def OutOfMemory_def ArrayIndexOutOfBounds_def ArrayStore_def NegativeArraySize_def IllegalMonitorState_def IllegalThreadState_def InterruptedException_def ArithmeticException_def)
lemmas sys_xcpts_neqs = sys_xcpts_neqs_aux sys_xcpts_neqs_aux[symmetric]
lemma Thread_neq_sys_xcpts_aux:
"Thread ≠ NullPointer"
"Thread ≠ ClassCast"
"Thread ≠ OutOfMemory"
"Thread ≠ ArrayIndexOutOfBounds"
"Thread ≠ ArrayStore"
"Thread ≠ NegativeArraySize"
"Thread ≠ ArithmeticException"
"Thread ≠ IllegalMonitorState"
"Thread ≠ IllegalThreadState"
"Thread ≠ InterruptedException"
by(simp_all add: Thread_def NullPointer_def ClassCast_def OutOfMemory_def ArrayIndexOutOfBounds_def ArrayStore_def NegativeArraySize_def IllegalMonitorState_def IllegalThreadState_def InterruptedException_def ArithmeticException_def)
lemmas Thread_neq_sys_xcpts = Thread_neq_sys_xcpts_aux Thread_neq_sys_xcpts_aux[symmetric]
subsection ‹Well-formedness for system classes and exceptions›
lemma
assumes "wf_syscls P"
shows wf_syscls_class_Object: "∃C fs ms. class P Object = Some (C,fs,ms)"
and wf_syscls_class_Thread: "∃C fs ms. class P Thread = Some (C,fs,ms)"
using assms
by(auto simp: map_of_SomeI wf_syscls_def is_class_def)
lemma [simp]:
assumes "wf_syscls P"
shows wf_syscls_is_class_Object: "is_class P Object"
and wf_syscls_is_class_Thread: "is_class P Thread"
using assms by(simp_all add: is_class_def wf_syscls_class_Object wf_syscls_class_Thread)
lemma wf_syscls_xcpt_subcls_Throwable:
"⟦ C ∈ sys_xcpts; wf_syscls P ⟧ ⟹ P ⊢ C ≼⇧* Throwable"
by(simp add: wf_syscls_def is_class_def class_def)
lemma wf_syscls_is_class_Throwable:
"wf_syscls P ⟹ is_class P Throwable"
by(auto simp add: wf_syscls_def is_class_def class_def map_of_SomeI)
lemma wf_syscls_is_class_sub_Throwable:
"⟦ wf_syscls P; P ⊢ C ≼⇧* Throwable ⟧ ⟹ is_class P C"
by(erule subcls_is_class1)(erule wf_syscls_is_class_Throwable)
lemma wf_syscls_is_class_xcpt:
"⟦ C ∈ sys_xcpts; wf_syscls P ⟧ ⟹ is_class P C"
by(blast intro: wf_syscls_is_class_sub_Throwable wf_syscls_xcpt_subcls_Throwable)
lemma wf_syscls_code [code]:
"wf_syscls P ⟷
(∀C ∈ set [Object, Throwable, Thread]. is_class P C) ∧ (∀C ∈ sys_xcpts. P ⊢ C ≼⇧* Throwable)"
by(simp only: wf_syscls_def) simp
end
Theory SystemClasses
section ‹System Classes›
theory SystemClasses
imports
Exceptions
begin
text ‹
This theory provides definitions for the ‹Object› class,
and the system exceptions.
Inline SystemClasses definition because they are polymorphic values that violate ML's value restriction.
›
text ‹
Object has actually superclass, but we set it to the empty string for code generation.
Any other class name (like @{term undefined}) would do as well except for code generation.
›
definition ObjectC :: "'m cdecl"
where [code_unfold]:
"ObjectC =
(Object, (STR '''',[],
[(wait,[],Void,Native),
(notify,[],Void,Native),
(notifyAll,[],Void,Native),
(hashcode,[],Integer,Native),
(clone,[],Class Object,Native),
(print,[Integer],Void,Native),
(currentThread,[],Class Thread,Native),
(interrupted,[],Boolean,Native),
(yield,[],Void,Native)
]))"
definition ThrowableC :: "'m cdecl"
where [code_unfold]: "ThrowableC ≡ (Throwable, (Object, [], []))"
definition NullPointerC :: "'m cdecl"
where [code_unfold]: "NullPointerC ≡ (NullPointer, (Throwable,[],[]))"
definition ClassCastC :: "'m cdecl"
where [code_unfold]: "ClassCastC ≡ (ClassCast, (Throwable,[],[]))"
definition OutOfMemoryC :: "'m cdecl"
where [code_unfold]: "OutOfMemoryC ≡ (OutOfMemory, (Throwable,[],[]))"
definition ArrayIndexOutOfBoundsC :: "'m cdecl"
where [code_unfold]: "ArrayIndexOutOfBoundsC ≡ (ArrayIndexOutOfBounds, (Throwable,[],[]))"
definition ArrayStoreC :: "'m cdecl"
where [code_unfold]: "ArrayStoreC ≡ (ArrayStore, (Throwable, [], []))"
definition NegativeArraySizeC :: "'m cdecl"
where [code_unfold]: "NegativeArraySizeC ≡ (NegativeArraySize, (Throwable,[],[]))"
definition ArithmeticExceptionC :: "'m cdecl"
where [code_unfold]: "ArithmeticExceptionC ≡ (ArithmeticException, (Throwable,[],[]))"
definition IllegalMonitorStateC :: "'m cdecl"
where [code_unfold]: "IllegalMonitorStateC ≡ (IllegalMonitorState, (Throwable,[],[]))"
definition IllegalThreadStateC :: "'m cdecl"
where [code_unfold]: "IllegalThreadStateC ≡ (IllegalThreadState, (Throwable,[],[]))"
definition InterruptedExceptionC :: "'m cdecl"
where [code_unfold]: "InterruptedExceptionC ≡ (InterruptedException, (Throwable,[],[]))"
definition SystemClasses :: "'m cdecl list"
where [code_unfold]:
"SystemClasses ≡
[ObjectC, ThrowableC, NullPointerC, ClassCastC, OutOfMemoryC,
ArrayIndexOutOfBoundsC, ArrayStoreC, NegativeArraySizeC,
ArithmeticExceptionC,
IllegalMonitorStateC, IllegalThreadStateC, InterruptedExceptionC]"
end
Theory Heap
section ‹An abstract heap model›
theory Heap
imports
Value
begin
primrec typeof :: "'addr val ⇀ ty"
where
"typeof Unit = Some Void"
| "typeof Null = Some NT"
| "typeof (Bool b) = Some Boolean"
| "typeof (Intg i) = Some Integer"
| "typeof (Addr a) = None"
datatype addr_loc =
CField cname vname
| ACell nat
lemma rec_addr_loc [simp]: "rec_addr_loc = case_addr_loc"
by(auto simp add: fun_eq_iff split: addr_loc.splits)
primrec is_volatile :: "'m prog ⇒ addr_loc ⇒ bool"
where
"is_volatile P (ACell n) = False"
| "is_volatile P (CField D F) = volatile (snd (snd (field P D F)))"
locale heap_base =
addr_base addr2thread_id thread_id2addr
for addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
+
fixes spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
begin
fun typeof_h :: "'heap ⇒ 'addr val ⇒ ty option" ("typeof⇘_⇙")
where
"typeof⇘h⇙ (Addr a) = map_option ty_of_htype (typeof_addr h a)"
| "typeof⇘h⇙ v = typeof v"
definition cname_of :: "'heap ⇒ 'addr ⇒ cname"
where "cname_of h a = the_Class (ty_of_htype (the (typeof_addr h a)))"
definition hext :: "'heap ⇒ 'heap ⇒ bool" ("_ ⊴ _" [51,51] 50)
where
"h ⊴ h' ≡ typeof_addr h ⊆⇩m typeof_addr h'"
context
notes [[inductive_internals]]
begin
inductive addr_loc_type :: "'m prog ⇒ 'heap ⇒ 'addr ⇒ addr_loc ⇒ ty ⇒ bool"
("_,_ ⊢ _@_ : _" [50, 50, 50, 50, 50] 51)
for P :: "'m prog" and h :: 'heap and a :: 'addr
where
addr_loc_type_field:
"⟦ typeof_addr h a = ⌊U⌋; P ⊢ class_type_of U has F:T (fm) in D ⟧
⟹ P,h ⊢ a@CField D F : T"
| addr_loc_type_cell:
"⟦ typeof_addr h a = ⌊Array_type T n'⌋; n < n' ⟧
⟹ P,h ⊢ a@ACell n : T"
end
definition typeof_addr_loc :: "'m prog ⇒ 'heap ⇒ 'addr ⇒ addr_loc ⇒ ty"
where "typeof_addr_loc P h a al = (THE T. P,h ⊢ a@al : T)"
definition deterministic_heap_ops :: bool
where
"deterministic_heap_ops ⟷
(∀h ad al v v'. heap_read h ad al v ⟶ heap_read h ad al v' ⟶ v = v') ∧
(∀h ad al v h' h''. heap_write h ad al v h' ⟶ heap_write h ad al v h'' ⟶ h' = h'') ∧
(∀h hT h' a h'' a'. (h', a) ∈ allocate h hT ⟶ (h'', a') ∈ allocate h hT ⟶ h' = h'' ∧ a = a') ∧
¬ spurious_wakeups"
end
lemma typeof_lit_eq_Boolean [simp]: "(typeof v = Some Boolean) = (∃b. v = Bool b)"
by(cases v)(auto)
lemma typeof_lit_eq_Integer [simp]: "(typeof v = Some Integer) = (∃i. v = Intg i)"
by(cases v)(auto)
lemma typeof_lit_eq_NT [simp]: "(typeof v = Some NT) = (v = Null)"
by(cases v)(auto)
lemma typeof_lit_eq_Void [simp]: "typeof v = Some Void ⟷ v = Unit"
by(cases v)(auto)
lemma typeof_lit_neq_Class [simp]: "typeof v ≠ Some (Class C)"
by(cases v) auto
lemma typeof_lit_neq_Array [simp]: "typeof v ≠ Some (Array T)"
by(cases v) auto
lemma typeof_NoneD [simp,dest]:
"typeof v = Some x ⟹ ¬ is_Addr v"
by (cases v) auto
lemma typeof_lit_is_type:
"typeof v = Some T ⟹ is_type P T"
by(cases v) auto
context heap_base begin
lemma typeof_h_eq_Boolean [simp]: "(typeof⇘h⇙ v = Some Boolean) = (∃b. v = Bool b)"
by(cases v)(auto)
lemma typeof_h_eq_Integer [simp]: "(typeof⇘h⇙ v = Some Integer) = (∃i. v = Intg i)"
by(cases v)(auto)
lemma typeof_h_eq_NT [simp]: "(typeof⇘h⇙ v = Some NT) = (v = Null)"
by(cases v)(auto)
lemma hextI:
"⟦ ⋀a C. typeof_addr h a = ⌊Class_type C⌋ ⟹ typeof_addr h' a = ⌊Class_type C⌋;
⋀a T n. typeof_addr h a = ⌊Array_type T n⌋ ⟹ typeof_addr h' a = ⌊Array_type T n⌋ ⟧
⟹ h ⊴ h'"
unfolding hext_def
by(rule map_leI)(case_tac v, simp_all)
lemma hext_objD:
assumes "h ⊴ h'"
and "typeof_addr h a = ⌊Class_type C⌋"
shows "typeof_addr h' a = ⌊Class_type C⌋"
using assms unfolding hext_def by(auto dest: map_le_SomeD)
lemma hext_arrD:
assumes "h ⊴ h'" "typeof_addr h a = ⌊Array_type T n⌋"
shows "typeof_addr h' a = ⌊Array_type T n⌋"
using assms unfolding hext_def by(blast dest: map_le_SomeD)
lemma hext_refl [iff]: "h ⊴ h"
by (rule hextI) blast+
lemma hext_trans [trans]: "⟦ h ⊴ h'; h' ⊴ h'' ⟧ ⟹ h ⊴ h''"
unfolding hext_def by(rule map_le_trans)
lemma typeof_lit_typeof:
"typeof v = ⌊T⌋ ⟹ typeof⇘h⇙ v = ⌊T⌋"
by(cases v)(simp_all)
lemma addr_loc_type_fun:
"⟦ P,h ⊢ a@al : T; P,h ⊢ a@al : T' ⟧ ⟹ T = T'"
by(auto elim!: addr_loc_type.cases dest: has_field_fun)
lemma THE_addr_loc_type:
"P,h ⊢ a@al : T ⟹ (THE T. P,h ⊢ a@al : T) = T"
by(rule the_equality)(auto dest: addr_loc_type_fun)
lemma typeof_addr_locI [simp]:
"P,h ⊢ a@al : T ⟹ typeof_addr_loc P h a al = T"
by(auto simp add: typeof_addr_loc_def dest: addr_loc_type_fun)
lemma deterministic_heap_opsI:
"⟦ ⋀h ad al v v'. ⟦ heap_read h ad al v; heap_read h ad al v' ⟧ ⟹ v = v';
⋀h ad al v h' h''. ⟦ heap_write h ad al v h'; heap_write h ad al v h'' ⟧ ⟹ h' = h'';
⋀h hT h' a h'' a'. ⟦ (h', a) ∈ allocate h hT; (h'', a') ∈ allocate h hT ⟧ ⟹ h' = h'' ∧ a = a';
¬ spurious_wakeups ⟧
⟹ deterministic_heap_ops"
unfolding deterministic_heap_ops_def by blast
lemma deterministic_heap_ops_readD:
"⟦ deterministic_heap_ops; heap_read h ad al v; heap_read h ad al v' ⟧ ⟹ v = v'"
unfolding deterministic_heap_ops_def by blast
lemma deterministic_heap_ops_writeD:
"⟦ deterministic_heap_ops; heap_write h ad al v h'; heap_write h ad al v h'' ⟧ ⟹ h' = h''"
unfolding deterministic_heap_ops_def by blast
lemma deterministic_heap_ops_allocateD:
"⟦ deterministic_heap_ops; (h', a) ∈ allocate h hT; (h'', a') ∈ allocate h hT ⟧ ⟹ h' = h'' ∧ a = a'"
unfolding deterministic_heap_ops_def by blast
lemma deterministic_heap_ops_no_spurious_wakeups:
"deterministic_heap_ops ⟹ ¬ spurious_wakeups"
unfolding deterministic_heap_ops_def by blast
end
locale addr_conv =
heap_base
addr2thread_id thread_id2addr
spurious_wakeups
empty_heap allocate typeof_addr heap_read heap_write
+
prog P
for addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and P :: "'m prog"
+
assumes addr2thread_id_inverse:
"⟦ typeof_addr h a = ⌊Class_type C⌋; P ⊢ C ≼⇧* Thread ⟧ ⟹ thread_id2addr (addr2thread_id a) = a"
begin
lemma typeof_addr_thread_id2_addr_addr2thread_id [simp]:
"⟦ typeof_addr h a = ⌊Class_type C⌋; P ⊢ C ≼⇧* Thread ⟧ ⟹ typeof_addr h (thread_id2addr (addr2thread_id a)) = ⌊Class_type C⌋"
by(simp add: addr2thread_id_inverse)
end
locale heap =
addr_conv
addr2thread_id thread_id2addr
spurious_wakeups
empty_heap allocate typeof_addr heap_read heap_write
P
for addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and P :: "'m prog"
+
assumes allocate_SomeD: "⟦ (h', a) ∈ allocate h hT; is_htype P hT ⟧ ⟹ typeof_addr h' a = Some hT"
and hext_allocate: "⋀a. (h', a) ∈ allocate h hT ⟹ h ⊴ h'"
and hext_heap_write:
"heap_write h a al v h' ⟹ h ⊴ h'"
begin
lemmas hext_heap_ops = hext_allocate hext_heap_write
lemma typeof_addr_hext_mono:
"⟦ h ⊴ h'; typeof_addr h a = ⌊hT⌋ ⟧ ⟹ typeof_addr h' a = ⌊hT⌋"
unfolding hext_def by(rule map_le_SomeD)
lemma hext_typeof_mono:
"⟦ h ⊴ h'; typeof⇘h⇙ v = Some T ⟧ ⟹ typeof⇘h'⇙ v = Some T"
by (cases v)(auto intro: typeof_addr_hext_mono)
lemma addr_loc_type_hext_mono:
"⟦ P,h ⊢ a@al : T; h ⊴ h' ⟧ ⟹ P,h' ⊢ a@al : T"
by(force elim!: addr_loc_type.cases intro: addr_loc_type.intros elim: typeof_addr_hext_mono dest: hext_arrD)
lemma type_of_hext_type_of:
"⟦ typeof⇘h⇙ w = ⌊T⌋; hext h h' ⟧ ⟹ typeof⇘h'⇙ w = ⌊T⌋"
by(rule hext_typeof_mono)
lemma hext_None: "⟦ h ⊴ h'; typeof_addr h' a = None ⟧ ⟹ typeof_addr h a = None"
by(rule ccontr)(auto dest: typeof_addr_hext_mono)
lemma map_typeof_hext_mono:
"⟦ map typeof⇘h⇙ vs = map Some Ts; h ⊴ h' ⟧ ⟹ map typeof⇘h'⇙ vs = map Some Ts"
apply(induct vs arbitrary: Ts)
apply(auto simp add: Cons_eq_map_conv intro: hext_typeof_mono)
done
lemma hext_typeof_addr_map_le:
"h ⊴ h' ⟹ typeof_addr h ⊆⇩m typeof_addr h'"
by(auto simp add: map_le_def dest: typeof_addr_hext_mono)
lemma hext_dom_typeof_addr_subset:
"h ⊴ h' ⟹ dom (typeof_addr h) ⊆ dom (typeof_addr h')"
by (metis hext_typeof_addr_map_le map_le_implies_dom_le)
end
declare heap_base.typeof_h.simps [code]
declare heap_base.cname_of_def [code]
end
Theory Observable_Events
section ‹Observable events in JinjaThreads›
theory Observable_Events
imports
Heap
"../Framework/FWState"
begin
datatype ('addr,'thread_id) obs_event =
ExternalCall 'addr mname "'addr val list" "'addr val"
| ReadMem 'addr addr_loc "'addr val"
| WriteMem 'addr addr_loc "'addr val"
| NewHeapElem 'addr htype
| ThreadStart 'thread_id
| ThreadJoin 'thread_id
| SyncLock 'addr
| SyncUnlock 'addr
| ObsInterrupt 'thread_id
| ObsInterrupted 'thread_id
instance obs_event :: (type, type) obs_action
proof qed
type_synonym
('addr, 'thread_id, 'x, 'heap) Jinja_thread_action =
"('addr,'thread_id,'x,'heap,'addr,('addr, 'thread_id) obs_event) thread_action"
print_translation ‹
let
fun tr'
[ a1, t1, x, h, a2
, Const (@{type_syntax "obs_event"}, _) $ a3 $ t2] =
if a1 = a2 andalso a2 = a3 andalso t1 = t2 then Syntax.const @{type_syntax "Jinja_thread_action"} $ a1 $ t1 $ x $ h
else raise Match;
in [(@{type_syntax "thread_action"}, K tr')]
end
›
typ "('addr, 'thread_id, 'x, 'heap) Jinja_thread_action"
lemma range_ty_of_htype: "range ty_of_htype ⊆ range Class ∪ range Array"
apply(rule subsetI)
apply(erule rangeE)
apply(rename_tac ht)
apply(case_tac ht)
apply auto
done
lemma some_choice: "(∃a. ∀b. P b (a b)) ⟷ (∀b. ∃a. P b a)"
by metis
definition convert_RA :: "'addr released_locks ⇒ ('addr :: addr, 'thread_id) obs_event list"
where "⋀ln. convert_RA ln = concat (map (λad. replicate (ln $ ad) (SyncLock ad)) (monitor_finfun_to_list ln))"
lemma set_convert_RA_not_New [simp]:
"⋀ln. NewHeapElem a CTn ∉ set (convert_RA ln)"
by(auto simp add: convert_RA_def)
lemma set_convert_RA_not_Read [simp]:
"⋀ln. ReadMem ad al v ∉ set (convert_RA ln)"
by(auto simp add: convert_RA_def)
end
Theory StartConfig
section ‹The initial configuration›
theory StartConfig
imports
Exceptions
Observable_Events
begin
definition initialization_list :: "cname list"
where
"initialization_list = Thread # sys_xcpts_list"
context heap_base begin
definition create_initial_object :: "'heap × 'addr list × bool ⇒ cname ⇒ 'heap × 'addr list × bool"
where
"create_initial_object =
(λ(h, ads, b) C.
if b
then let HA = allocate h (Class_type C)
in if HA = {} then (h, ads, False)
else let (h', a'') = SOME ha. ha ∈ HA in (h', ads @ [a''], True)
else (h, ads, False))"
definition start_heap_data :: "'heap × 'addr list × bool"
where
"start_heap_data = foldl create_initial_object (empty_heap, [], True) initialization_list"
definition start_heap :: 'heap
where "start_heap = fst start_heap_data"
definition start_heap_ok :: bool
where "start_heap_ok = snd (snd (start_heap_data))"
definition start_heap_obs :: "('addr, 'thread_id) obs_event list"
where
"start_heap_obs =
map (λ(C, a). NewHeapElem a (Class_type C)) (zip initialization_list (fst (snd start_heap_data)))"
definition start_addrs :: "'addr list"
where "start_addrs = fst (snd start_heap_data)"
definition addr_of_sys_xcpt :: "cname ⇒ 'addr"
where "addr_of_sys_xcpt C = the (map_of (zip initialization_list start_addrs) C)"
definition start_tid :: 'thread_id
where "start_tid = addr2thread_id (hd start_addrs)"
definition start_state :: "(cname ⇒ mname ⇒ ty list ⇒ ty ⇒ 'm ⇒ 'addr val list ⇒ 'x) ⇒ 'm prog ⇒ cname ⇒ mname ⇒ 'addr val list ⇒ ('addr,'thread_id,'x,'heap,'addr) state"
where
"start_state f P C M vs ≡
let (D, Ts, T, m) = method P C M
in (K$ None, ([start_tid ↦ (f D M Ts T (the m) vs, no_wait_locks)], start_heap), Map.empty, {})"
lemma create_initial_object_simps:
"create_initial_object (h, ads, b) C =
(if b
then let HA = allocate h (Class_type C)
in if HA = {} then (h, ads, False)
else let (h', a'') = SOME ha. ha ∈ HA in (h', ads @ [a''], True)
else (h, ads, False))"
unfolding create_initial_object_def by simp
lemma create_initial_object_False [simp]:
"create_initial_object (h, ads, False) C = (h, ads, False)"
by(simp add: create_initial_object_simps)
lemma foldl_create_initial_object_False [simp]:
"foldl create_initial_object (h, ads, False) Cs = (h, ads, False)"
by(induct Cs) simp_all
lemma NewHeapElem_start_heap_obs_start_addrsD:
"NewHeapElem a CTn ∈ set start_heap_obs ⟹ a ∈ set start_addrs"
unfolding start_heap_obs_def start_addrs_def
by(auto dest: set_zip_rightD)
lemma shr_start_state: "shr (start_state f P C M vs) = start_heap"
by(simp add: start_state_def split_beta)
lemma start_heap_obs_not_Read:
"ReadMem ad al v ∉ set start_heap_obs"
unfolding start_heap_obs_def by auto
lemma length_initialization_list_le_length_start_addrs:
"length initialization_list ≥ length start_addrs"
proof -
{ fix h ads xs
have "length (fst (snd (foldl create_initial_object (h, ads, True) xs))) ≤ length ads + length xs"
proof(induct xs arbitrary: h ads)
case Nil thus ?case by simp
next
case (Cons x xs)
from this[of "fst (SOME ha. ha ∈ allocate h (Class_type x))" "ads @ [snd (SOME ha. ha ∈ allocate h (Class_type x))]"]
show ?case by(clarsimp simp add: create_initial_object_simps split_beta)
qed }
from this[of empty_heap "[]" initialization_list]
show ?thesis unfolding start_heap_def start_addrs_def start_heap_data_def by simp
qed
lemma (in -) distinct_initialization_list:
"distinct initialization_list"
by(simp add: initialization_list_def sys_xcpts_list_def sys_xcpts_neqs Thread_neq_sys_xcpts)
lemma (in -) wf_syscls_initialization_list_is_class:
"⟦ wf_syscls P; C ∈ set initialization_list ⟧ ⟹ is_class P C"
by(auto simp add: initialization_list_def sys_xcpts_list_def wf_syscls_is_class_xcpt)
lemma start_addrs_NewHeapElem_start_heap_obsD:
"a ∈ set start_addrs ⟹ ∃CTn. NewHeapElem a CTn ∈ set start_heap_obs"
using length_initialization_list_le_length_start_addrs
unfolding start_heap_obs_def start_addrs_def
by(force simp add: set_zip in_set_conv_nth intro: rev_image_eqI)
lemma in_set_start_addrs_conv_NewHeapElem:
"a ∈ set start_addrs ⟷ (∃CTn. NewHeapElem a CTn ∈ set start_heap_obs)"
by(blast dest: start_addrs_NewHeapElem_start_heap_obsD intro: NewHeapElem_start_heap_obs_start_addrsD)
subsection ‹@{term preallocated}›
definition preallocated :: "'heap ⇒ bool"
where "preallocated h ≡ ∀C ∈ sys_xcpts. typeof_addr h (addr_of_sys_xcpt C) = ⌊Class_type C⌋"
lemma typeof_addr_sys_xcp:
"⟦ preallocated h; C ∈ sys_xcpts ⟧ ⟹ typeof_addr h (addr_of_sys_xcpt C) = ⌊Class_type C⌋"
by(simp add: preallocated_def)
lemma typeof_sys_xcp:
"⟦ preallocated h; C ∈ sys_xcpts ⟧ ⟹ typeof⇘h⇙ (Addr (addr_of_sys_xcpt C)) = ⌊Class C⌋"
by(simp add: typeof_addr_sys_xcp)
lemma addr_of_sys_xcpt_start_addr:
"⟦ start_heap_ok; C ∈ sys_xcpts ⟧ ⟹ addr_of_sys_xcpt C ∈ set start_addrs"
unfolding start_heap_ok_def start_heap_data_def initialization_list_def sys_xcpts_list_def
preallocated_def start_heap_def start_addrs_def
apply(simp split: prod.split_asm if_split_asm add: create_initial_object_simps)
apply(erule sys_xcpts_cases)
apply(simp_all add: addr_of_sys_xcpt_def start_addrs_def start_heap_data_def initialization_list_def sys_xcpts_list_def create_initial_object_simps)
done
lemma [simp]:
assumes "preallocated h"
shows typeof_ClassCast: "typeof_addr h (addr_of_sys_xcpt ClassCast) = Some(Class_type ClassCast)"
and typeof_OutOfMemory: "typeof_addr h (addr_of_sys_xcpt OutOfMemory) = Some(Class_type OutOfMemory)"
and typeof_NullPointer: "typeof_addr h (addr_of_sys_xcpt NullPointer) = Some(Class_type NullPointer)"
and typeof_ArrayIndexOutOfBounds:
"typeof_addr h (addr_of_sys_xcpt ArrayIndexOutOfBounds) = Some(Class_type ArrayIndexOutOfBounds)"
and typeof_ArrayStore: "typeof_addr h (addr_of_sys_xcpt ArrayStore) = Some(Class_type ArrayStore)"
and typeof_NegativeArraySize: "typeof_addr h (addr_of_sys_xcpt NegativeArraySize) = Some(Class_type NegativeArraySize)"
and typeof_ArithmeticException: "typeof_addr h (addr_of_sys_xcpt ArithmeticException) = Some(Class_type ArithmeticException)"
and typeof_IllegalMonitorState: "typeof_addr h (addr_of_sys_xcpt IllegalMonitorState) = Some(Class_type IllegalMonitorState)"
and typeof_IllegalThreadState: "typeof_addr h (addr_of_sys_xcpt IllegalThreadState) = Some(Class_type IllegalThreadState)"
and typeof_InterruptedException: "typeof_addr h (addr_of_sys_xcpt InterruptedException) = Some(Class_type InterruptedException)"
using assms
by(simp_all add: typeof_addr_sys_xcp)
lemma cname_of_xcp [simp]:
"⟦ preallocated h; C ∈ sys_xcpts ⟧ ⟹ cname_of h (addr_of_sys_xcpt C) = C"
by(drule (1) typeof_addr_sys_xcp)(simp add: cname_of_def)
lemma preallocated_hext:
"⟦ preallocated h; h ⊴ h' ⟧ ⟹ preallocated h'"
by(auto simp add: preallocated_def dest: hext_objD)
end
context heap begin
lemma preallocated_heap_ops:
assumes "preallocated h"
shows preallocated_allocate: "⋀a. (h', a) ∈ allocate h hT ⟹ preallocated h'"
and preallocated_write_field: "heap_write h a al v h' ⟹ preallocated h'"
using preallocated_hext[OF assms, of h']
by(blast intro: hext_heap_ops)+
lemma not_empty_pairE: "⟦ A ≠ {}; ⋀a b. (a, b) ∈ A ⟹ thesis ⟧ ⟹ thesis"
by auto
lemma allocate_not_emptyI: "(h', a) ∈ allocate h hT ⟹ allocate h hT ≠ {}"
by auto
lemma allocate_Eps:
"⟦ (h'', a'') ∈ allocate h hT; (SOME ha. ha ∈ allocate h hT) = (h', a') ⟧ ⟹ (h', a') ∈ allocate h hT"
by(drule sym)(auto intro: someI)
lemma preallocated_start_heap:
"⟦ start_heap_ok; wf_syscls P ⟧ ⟹ preallocated start_heap"
unfolding start_heap_ok_def start_heap_data_def initialization_list_def sys_xcpts_list_def
preallocated_def start_heap_def start_addrs_def
apply(clarsimp split: prod.split_asm if_split_asm simp add: create_initial_object_simps)
apply(erule not_empty_pairE)+
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(rotate_tac 13)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(frule allocate_SomeD, simp add: wf_syscls_is_class_xcpt, frule hext_allocate, rotate_tac 1)
apply(erule sys_xcpts_cases)
apply(simp_all add: addr_of_sys_xcpt_def initialization_list_def sys_xcpts_list_def sys_xcpts_neqs Thread_neq_sys_xcpts start_heap_data_def start_addrs_def create_initial_object_simps allocate_not_emptyI split del: if_split)
apply(assumption|erule typeof_addr_hext_mono)+
done
lemma start_tid_start_addrs:
"⟦ wf_syscls P; start_heap_ok ⟧ ⟹ thread_id2addr start_tid ∈ set start_addrs"
unfolding start_heap_ok_def start_heap_data_def initialization_list_def sys_xcpts_list_def
preallocated_def start_heap_def start_addrs_def
apply(simp split: prod.split_asm if_split_asm add: create_initial_object_simps addr_of_sys_xcpt_def start_addrs_def start_tid_def start_heap_data_def initialization_list_def sys_xcpts_list_def)
apply(erule not_empty_pairE)+
apply(drule (1) allocate_Eps)
apply(rotate_tac -1)
apply(drule allocate_SomeD, simp)
apply(auto intro: addr2thread_id_inverse)
done
lemma
assumes "wf_syscls P"
shows dom_typeof_addr_start_heap: "set start_addrs ⊆ dom (typeof_addr start_heap)"
and distinct_start_addrs: "distinct start_addrs"
proof -
{ fix h ads b and Cs xs :: "cname list"
assume "set ads ⊆ dom (typeof_addr h)" and "distinct (Cs @ xs)" and "length Cs = length ads"
and "⋀C a. (C, a) ∈ set (zip Cs ads) ⟹ typeof_addr h a = ⌊Class_type C⌋"
and "⋀C. C ∈ set xs ⟹ is_class P C"
hence "set (fst (snd (foldl create_initial_object (h, ads, b) xs))) ⊆
dom (typeof_addr (fst (foldl create_initial_object (h, ads, b) xs))) ∧
(distinct ads ⟶ distinct (fst (snd (foldl create_initial_object (h, ads, b) xs))))"
(is "?concl xs h ads b Cs")
proof(induct xs arbitrary: h ads b Cs)
case Nil thus ?case by auto
next
case (Cons x xs)
note ads = ‹set ads ⊆ dom (typeof_addr h)›
note dist = ‹distinct (Cs @ x # xs)›
note len = ‹length Cs = length ads›
note type = ‹⋀C a. (C, a) ∈ set (zip Cs ads) ⟹ typeof_addr h a = ⌊Class_type C⌋›
note is_class = ‹⋀C. C ∈ set (x # xs) ⟹ is_class P C›
show ?case
proof(cases "b ∧ allocate h (Class_type x) ≠ {}")
case False thus ?thesis
using ads len by(auto simp add: create_initial_object_simps zip_append1)
next
case [simp]: True
obtain h' a' where h'a': "(SOME ha. ha ∈ allocate h (Class_type x)) = (h', a')"
by(cases "SOME ha. ha ∈ allocate h (Class_type x)")
with True have new_obj: "(h', a') ∈ allocate h (Class_type x)"
by(auto simp del: True intro: allocate_Eps)
hence hext: "h ⊴ h'" by(rule hext_allocate)
with ads new_obj have ads': "set ads ⊆ dom (typeof_addr h')"
by(auto dest: typeof_addr_hext_mono[OF hext_allocate])
moreover {
from new_obj ads' is_class[of x]
have "set (ads @ [a']) ⊆ dom (typeof_addr h')"
by(auto dest: allocate_SomeD)
moreover from dist have "distinct ((Cs @ [x]) @ xs)" by simp
moreover have "length (Cs @ [x]) = length (ads @ [a'])" using len by simp
moreover {
fix C a
assume "(C, a) ∈ set (zip (Cs @ [x]) (ads @ [a']))"
hence "typeof_addr h' a = ⌊Class_type C⌋"
using hext new_obj type[of C a] len is_class
by(auto dest: allocate_SomeD hext_objD) }
note type' = this
moreover have is_class': "⋀C. C ∈ set xs ⟹ is_class P C" using is_class by simp
ultimately have "?concl xs h' (ads @ [a']) True (Cs @ [x])" by(rule Cons)
moreover have "a' ∉ set ads"
proof
assume a': "a' ∈ set ads"
then obtain C where "(C, a') ∈ set (zip Cs ads)" "C ∈ set Cs"
using len unfolding set_zip in_set_conv_nth by auto
hence "typeof_addr h a' = ⌊Class_type C⌋" by-(rule type)
with hext have "typeof_addr h' a' = ⌊Class_type C⌋" by(rule typeof_addr_hext_mono)
moreover from new_obj is_class
have "typeof_addr h' a' = ⌊Class_type x⌋" by(auto dest: allocate_SomeD)
ultimately have "C = x" by simp
with dist ‹C ∈ set Cs› show False by simp
qed
moreover note calculation }
ultimately show ?thesis by(simp add: create_initial_object_simps new_obj h'a')
qed
qed }
from this[of "[]" empty_heap "[]" initialization_list True]
distinct_initialization_list wf_syscls_initialization_list_is_class[OF assms]
show "set start_addrs ⊆ dom (typeof_addr start_heap)"
and "distinct start_addrs"
unfolding start_heap_def start_addrs_def start_heap_data_def by auto
qed
lemma NewHeapElem_start_heap_obsD:
assumes "wf_syscls P"
and "NewHeapElem a hT ∈ set start_heap_obs"
shows "typeof_addr start_heap a = ⌊hT⌋"
proof -
show ?thesis
proof(cases hT)
case (Class_type C)
{ fix h ads b xs Cs
assume "(C, a) ∈ set (zip (Cs @ xs) (fst (snd (foldl create_initial_object (h, ads, b) xs))))"
and "∀(C, a) ∈ set (zip Cs ads). typeof_addr h a = ⌊Class_type C⌋"
and "length Cs = length ads"
and "∀C ∈ set xs. is_class P C"
hence "typeof_addr (fst (foldl create_initial_object (h, ads, b) xs)) a = ⌊Class_type C⌋"
proof(induct xs arbitrary: h ads b Cs)
case Nil thus ?case by auto
next
case (Cons x xs)
note inv = ‹∀(C, a) ∈ set (zip Cs ads). typeof_addr h a = ⌊Class_type C⌋›
and Ca = ‹(C, a) ∈ set (zip (Cs @ x # xs) (fst (snd (foldl create_initial_object (h, ads, b) (x # xs)))))›
and len = ‹length Cs = length ads›
and is_class = ‹∀C ∈ set (x # xs). is_class P C›
show ?case
proof(cases "b ∧ allocate h (Class_type x) ≠ {}")
case False thus ?thesis
using inv Ca len by(auto simp add: create_initial_object_simps zip_append1 split: if_split_asm)
next
case [simp]: True
obtain h' a' where h'a': "(SOME ha. ha ∈ allocate h (Class_type x)) = (h', a')"
by(cases "SOME ha. ha ∈ allocate h (Class_type x)")
with True have new_obj: "(h', a') ∈ allocate h (Class_type x)"
by(auto simp del: True intro: allocate_Eps)
hence hext: "h ⊴ h'" by(rule hext_allocate)
have "(C, a) ∈ set (zip ((Cs @ [x]) @ xs) (fst (snd (foldl create_initial_object (h', ads @ [a'], True) xs))))"
using Ca new_obj by(simp add: create_initial_object_simps h'a')
moreover have "∀(C, a)∈set (zip (Cs @ [x]) (ads @ [a'])). typeof_addr h' a = ⌊Class_type C⌋"
proof(clarify)
fix C a
assume "(C, a) ∈ set (zip (Cs @ [x]) (ads @ [a']))"
thus "typeof_addr h' a = ⌊Class_type C⌋"
using inv len hext new_obj is_class by(auto dest: allocate_SomeD typeof_addr_hext_mono)
qed
moreover have "length (Cs @ [x]) = length (ads @ [a'])" using len by simp
moreover have "∀C ∈ set xs. is_class P C" using is_class by simp
ultimately have "typeof_addr (fst (foldl create_initial_object (h', ads @ [a'], True) xs)) a = ⌊Class_type C⌋"
by(rule Cons)
thus ?thesis using new_obj by(simp add: create_initial_object_simps h'a')
qed
qed }
from this[of "[]" initialization_list empty_heap "[]" True] assms wf_syscls_initialization_list_is_class[of P]
show ?thesis by(auto simp add: start_heap_obs_def start_heap_data_def start_heap_def Class_type)
next
case Array_type thus ?thesis using assms
by(auto simp add: start_heap_obs_def start_heap_data_def start_heap_def)
qed
qed
end
subsection ‹Code generation›
definition pick_addr :: "('heap × 'addr) set ⇒ 'heap × 'addr"
where "pick_addr HA = (SOME ha. ha ∈ HA)"
lemma pick_addr_code [code]:
"pick_addr (set [ha]) = ha"
by(simp add: pick_addr_def)
lemma (in heap_base) start_heap_data_code:
"start_heap_data =
(let
(h, ads, b) = foldl
(λ(h, ads, b) C.
if b then
let HA = allocate h (Class_type C)
in if HA = {} then (h, ads, False)
else let (h', a'') = pick_addr HA in (h', a'' # ads, True)
else (h, ads, False))
(empty_heap, [], True)
initialization_list
in (h, rev ads, b))"
unfolding start_heap_data_def create_initial_object_def pick_addr_def
by(rule rev_induct)(simp_all add: split_beta)
lemmas [code] =
heap_base.start_heap_data_code
heap_base.start_heap_def
heap_base.start_heap_ok_def
heap_base.start_heap_obs_def
heap_base.start_addrs_def
heap_base.addr_of_sys_xcpt_def
heap_base.start_tid_def
heap_base.start_state_def
end
Theory Conform
section ‹Conformance Relations for Type Soundness Proofs›
theory Conform
imports
StartConfig
begin
context heap_base begin
definition conf :: "'m prog ⇒ 'heap ⇒ 'addr val ⇒ ty ⇒ bool" ("_,_ ⊢ _ :≤ _" [51,51,51,51] 50)
where "P,h ⊢ v :≤ T ≡ ∃T'. typeof⇘h⇙ v = Some T' ∧ P ⊢ T' ≤ T"
definition lconf :: "'m prog ⇒ 'heap ⇒ (vname ⇀ 'addr val) ⇒ (vname ⇀ ty) ⇒ bool" ("_,_ ⊢ _ '(:≤') _" [51,51,51,51] 50)
where "P,h ⊢ l (:≤) E ≡ ∀V v. l V = Some v ⟶ (∃T. E V = Some T ∧ P,h ⊢ v :≤ T)"
abbreviation confs :: "'m prog ⇒ 'heap ⇒ 'addr val list ⇒ ty list ⇒ bool" ("_,_ ⊢ _ [:≤] _" [51,51,51,51] 50)
where "P,h ⊢ vs [:≤] Ts == list_all2 (conf P h) vs Ts"
definition tconf :: "'m prog ⇒ 'heap ⇒ 'thread_id ⇒ bool" ("_,_ ⊢ _ √t" [51,51,51] 50)
where "P,h ⊢ t √t ≡ ∃C. typeof_addr h (thread_id2addr t) = ⌊Class_type C⌋ ∧ P ⊢ C ≼⇧* Thread"
end
locale heap_conf_base =
heap_base +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
fixes hconf :: "'heap ⇒ bool"
and P :: "'m prog"
sublocale heap_conf_base < prog P .
locale heap_conf =
heap
addr2thread_id thread_id2addr
spurious_wakeups
empty_heap allocate typeof_addr heap_read heap_write
P
+
heap_conf_base
addr2thread_id thread_id2addr
spurious_wakeups
empty_heap allocate typeof_addr heap_read heap_write
hconf P
for addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and hconf :: "'heap ⇒ bool"
and P :: "'m prog"
+
assumes hconf_empty [iff]: "hconf empty_heap"
and typeof_addr_is_type: "⟦ typeof_addr h a = ⌊hT⌋; hconf h ⟧ ⟹ is_type P (ty_of_htype hT)"
and hconf_allocate_mono: "⋀a. ⟦ (h', a) ∈ allocate h hT; hconf h; is_htype P hT ⟧ ⟹ hconf h'"
and hconf_heap_write_mono:
"⋀T. ⟦ heap_write h a al v h'; hconf h; P,h ⊢ a@al : T; P,h ⊢ v :≤ T ⟧ ⟹ hconf h'"
locale heap_progress =
heap_conf
addr2thread_id thread_id2addr
spurious_wakeups
empty_heap allocate typeof_addr heap_read heap_write
hconf P
for addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and hconf :: "'heap ⇒ bool"
and P :: "'m prog"
+
assumes heap_read_total: "⟦ hconf h; P,h ⊢ a@al : T ⟧ ⟹ ∃v. heap_read h a al v ∧ P,h ⊢ v :≤ T"
and heap_write_total: "⟦ hconf h; P,h ⊢ a@al : T; P,h ⊢ v :≤ T ⟧ ⟹ ∃h'. heap_write h a al v h'"
locale heap_conf_read =
heap_conf
addr2thread_id thread_id2addr
spurious_wakeups
empty_heap allocate typeof_addr heap_read heap_write
hconf P
for addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and hconf :: "'heap ⇒ bool"
and P :: "'m prog"
+
assumes heap_read_conf: "⟦ heap_read h a al v; P,h ⊢ a@al : T; hconf h ⟧ ⟹ P,h ⊢ v :≤ T"
locale heap_typesafe =
heap_conf_read +
heap_progress +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and hconf :: "'heap ⇒ bool"
and P :: "'m prog"
context heap_conf begin
lemmas hconf_heap_ops_mono =
hconf_allocate_mono
hconf_heap_write_mono
end
subsection‹Value conformance ‹:≤››
context heap_base begin
lemma conf_Null [simp]: "P,h ⊢ Null :≤ T = P ⊢ NT ≤ T"
unfolding conf_def by(simp (no_asm))
lemma typeof_conf[simp]: "typeof⇘h⇙ v = Some T ⟹ P,h ⊢ v :≤ T"
unfolding conf_def by (cases v) auto
lemma typeof_lit_conf[simp]: "typeof v = Some T ⟹ P,h ⊢ v :≤ T"
by (rule typeof_conf[OF typeof_lit_typeof])
lemma defval_conf[simp]: "P,h ⊢ default_val T :≤ T"
unfolding conf_def by (cases T) auto
lemma conf_widen: "P,h ⊢ v :≤ T ⟹ P ⊢ T ≤ T' ⟹ P,h ⊢ v :≤ T'"
unfolding conf_def by (cases v) (auto intro: widen_trans)
lemma conf_sys_xcpt:
"⟦preallocated h; C ∈ sys_xcpts⟧ ⟹ P,h ⊢ Addr (addr_of_sys_xcpt C) :≤ Class C"
by(simp add: conf_def typeof_addr_sys_xcp)
lemma conf_NT [iff]: "P,h ⊢ v :≤ NT = (v = Null)"
by (auto simp add: conf_def)
lemma is_IntgI: "P,h ⊢ v :≤ Integer ⟹ is_Intg v"
by (unfold conf_def) auto
lemma is_BoolI: "P,h ⊢ v :≤ Boolean ⟹ is_Bool v"
by (unfold conf_def) auto
lemma is_RefI: "P,h ⊢ v :≤ T ⟹ is_refT T ⟹ is_Ref v"
by(cases v)(auto elim: is_refT.cases simp add: conf_def is_Ref_def)
lemma non_npD:
"⟦ v ≠ Null; P,h ⊢ v :≤ Class C; C ≠ Object ⟧
⟹ ∃a C'. v = Addr a ∧ typeof_addr h a = ⌊Class_type C'⌋ ∧ P ⊢ C' ≼⇧* C"
by(cases v)(auto simp add: conf_def widen_Class)
lemma non_npD2:
"⟦v ≠ Null; P,h ⊢ v :≤ Class C ⟧
⟹ ∃a hT. v = Addr a ∧ typeof_addr h a = ⌊hT⌋ ∧ P ⊢ class_type_of hT ≼⇧* C"
by(cases v)(auto simp add: conf_def widen_Class)
end
context heap begin
lemma conf_hext: "⟦ h ⊴ h'; P,h ⊢ v :≤ T ⟧ ⟹ P,h' ⊢ v :≤ T"
unfolding conf_def by(cases v)(auto dest: typeof_addr_hext_mono)
lemma conf_heap_ops_mono:
assumes "P,h ⊢ v :≤ T"
shows conf_allocate_mono: "(h', a) ∈ allocate h hT ⟹ P,h' ⊢ v :≤ T"
and conf_heap_write_mono: "heap_write h a al v' h' ⟹ P,h' ⊢ v :≤ T"
using assms
by(auto intro: conf_hext dest: hext_heap_ops)
end
subsection‹Value list conformance ‹[:≤]››
context heap_base begin
lemma confs_widens [trans]: "⟦P,h ⊢ vs [:≤] Ts; P ⊢ Ts [≤] Ts'⟧ ⟹ P,h ⊢ vs [:≤] Ts'"
by (rule list_all2_trans)(rule conf_widen)
lemma confs_rev: "P,h ⊢ rev s [:≤] t = (P,h ⊢ s [:≤] rev t)"
by(rule list_all2_rev1)
lemma confs_conv_map:
"P,h ⊢ vs [:≤] Ts' = (∃Ts. map typeof⇘h⇙ vs = map Some Ts ∧ P ⊢ Ts [≤] Ts')"
apply(induct vs arbitrary: Ts')
apply simp
apply(case_tac Ts')
apply(auto simp add:conf_def)
apply(rule_tac x="T' # Ts" in exI)
apply(simp add: fun_of_def)
done
lemma confs_Cons2: "P,h ⊢ xs [:≤] y#ys = (∃z zs. xs = z#zs ∧ P,h ⊢ z :≤ y ∧ P,h ⊢ zs [:≤] ys)"
by (rule list_all2_Cons2)
end
context heap begin
lemma confs_hext: "P,h ⊢ vs [:≤] Ts ⟹ h ⊴ h' ⟹ P,h' ⊢ vs [:≤] Ts"
by (erule list_all2_mono, erule conf_hext, assumption)
end
subsection ‹Local variable conformance›
context heap_base begin
lemma lconf_upd:
"⟦ P,h ⊢ l (:≤) E; P,h ⊢ v :≤ T; E V = Some T ⟧ ⟹ P,h ⊢ l(V↦v) (:≤) E"
unfolding lconf_def by auto
lemma lconf_empty [iff]: "P,h ⊢ Map.empty (:≤) E"
by(simp add:lconf_def)
lemma lconf_upd2: "⟦P,h ⊢ l (:≤) E; P,h ⊢ v :≤ T⟧ ⟹ P,h ⊢ l(V↦v) (:≤) E(V↦T)"
by(simp add:lconf_def)
end
context heap begin
lemma lconf_hext: "⟦ P,h ⊢ l (:≤) E; h ⊴ h' ⟧ ⟹ P,h' ⊢ l (:≤) E"
unfolding lconf_def by(fast elim: conf_hext)
end
subsection ‹Thread object conformance›
context heap_base begin
lemma tconfI: "⟦ typeof_addr h (thread_id2addr t) = ⌊Class_type C⌋; P ⊢ C ≼⇧* Thread ⟧ ⟹ P,h ⊢ t √t"
by(simp add: tconf_def)
lemma tconfD: "P,h ⊢ t √t ⟹ ∃C. typeof_addr h (thread_id2addr t) = ⌊Class_type C⌋ ∧ P ⊢ C ≼⇧* Thread"
by(auto simp add: tconf_def)
end
context heap begin
lemma tconf_hext_mono: "⟦ P,h ⊢ t √t; h ⊴ h' ⟧ ⟹ P,h' ⊢ t √t"
by(auto simp add: tconf_def dest: typeof_addr_hext_mono)
lemma tconf_heap_ops_mono:
assumes "P,h ⊢ t √t"
shows tconf_allocate_mono: "(h', a) ∈ allocate h hT ⟹ P,h' ⊢ t √t"
and tconf_heap_write_mono: "heap_write h a al v h' ⟹ P,h' ⊢ t √t"
using tconf_hext_mono[OF assms, of h']
by(blast intro: hext_heap_ops)+
lemma tconf_start_heap_start_tid:
"⟦ start_heap_ok; wf_syscls P ⟧ ⟹ P,start_heap ⊢ start_tid √t"
unfolding start_tid_def start_heap_def start_heap_ok_def start_heap_data_def initialization_list_def addr_of_sys_xcpt_def start_addrs_def sys_xcpts_list_def
apply(clarsimp split: prod.split_asm simp add: create_initial_object_simps split: if_split_asm)
apply(erule not_empty_pairE)+
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule allocate_SomeD[where hT="Class_type Thread"])
apply simp
apply(rule tconfI)
apply(erule typeof_addr_hext_mono[OF hext_allocate])+
apply simp
apply blast
done
lemma start_heap_write_typeable:
assumes "WriteMem ad al v ∈ set start_heap_obs"
shows "∃T. P,start_heap ⊢ ad@al : T ∧ P,start_heap ⊢ v :≤ T"
using assms
unfolding start_heap_obs_def start_heap_def
by clarsimp
end
subsection ‹Well-formed start state›
context heap_base begin
inductive wf_start_state :: "'m prog ⇒ cname ⇒ mname ⇒ 'addr val list ⇒ bool"
for P :: "'m prog" and C :: cname and M :: mname and vs :: "'addr val list"
where
wf_start_state:
"⟦ P ⊢ C sees M:Ts→T = ⌊meth⌋ in D; start_heap_ok; P,start_heap ⊢ vs [:≤] Ts ⟧
⟹ wf_start_state P C M vs"
end
end
Theory ExternalCall
section ‹Semantics of method calls that cannot be defined inside JinjaThreads›
theory ExternalCall
imports
"../Framework/FWSemantics"
Conform
begin
type_synonym
('addr,'thread_id,'heap) external_thread_action = "('addr, 'thread_id, cname × mname × 'addr,'heap) Jinja_thread_action"
print_translation ‹
let
fun tr'
[a1, t
, Const (@{type_syntax "prod"}, _) $ Const (@{type_syntax "String.literal"}, _) $
(Const (@{type_syntax "prod"}, _) $ Const (@{type_syntax "String.literal"}, _) $ a2)
, h] =
if a1 = a2 then Syntax.const @{type_syntax "external_thread_action"} $ a1 $ t $ h
else raise Match;
in [(@{type_syntax "Jinja_thread_action"}, K tr')]
end
›
typ "('addr,'thread_id,'heap) external_thread_action"
subsection ‹Typing of external calls›
inductive external_WT_defs :: "cname ⇒ mname ⇒ ty list ⇒ ty ⇒ bool" ("(_∙_'(_')) :: _" [50, 0, 0, 50] 60)
where
"Thread∙start([]) :: Void"
| "Thread∙join([]) :: Void"
| "Thread∙interrupt([]) :: Void"
| "Thread∙isInterrupted([]) :: Boolean"
| "Object∙wait([]) :: Void"
| "Object∙notify([]) :: Void"
| "Object∙notifyAll([]) :: Void"
| "Object∙clone([]) :: Class Object"
| "Object∙hashcode([]) :: Integer"
| "Object∙print([Integer]) :: Void"
| "Object∙currentThread([]) :: Class Thread"
| "Object∙interrupted([]) :: Boolean"
| "Object∙yield([]) :: Void"
inductive_cases external_WT_defs_cases:
"a∙start(vs) :: T"
"a∙join(vs) :: T"
"a∙interrupt(vs) :: T"
"a∙isInterrupted(vs) :: T"
"a∙wait(vs) :: T"
"a∙notify(vs) :: T"
"a∙notifyAll(vs) :: T"
"a∙clone(vs) :: T"
"a∙hashcode(vs) :: T"
"a∙print(vs) :: T"
"a∙currentThread(vs) :: T"
"a∙interrupted([]) :: T"
"a∙yield(vs) :: T"
inductive is_native :: "'m prog ⇒ htype ⇒ mname ⇒ bool"
for P :: "'m prog" and hT :: htype and M :: mname
where "⟦ P ⊢ class_type_of hT sees M:Ts→T = Native in D; D∙M(Ts) :: T ⟧ ⟹ is_native P hT M"
lemma is_nativeD: "is_native P hT M ⟹ ∃Ts T D. P ⊢ class_type_of hT sees M:Ts→T = Native in D ∧ D∙M(Ts)::T"
by(simp add: is_native.simps)
inductive (in heap_base) external_WT' :: "'m prog ⇒ 'heap ⇒ 'addr ⇒ mname ⇒ 'addr val list ⇒ ty ⇒ bool"
("_,_ ⊢ (_∙_'(_')) : _" [50,0,0,0,50] 60)
for P :: "'m prog" and h :: 'heap and a :: 'addr and M :: mname and vs :: "'addr val list" and U :: ty
where
"⟦ typeof_addr h a = ⌊hT⌋; map typeof⇘h⇙ vs = map Some Ts; P ⊢ class_type_of hT sees M:Ts'→U = Native in D;
P ⊢ Ts [≤] Ts' ⟧
⟹ P,h ⊢ a∙M(vs) : U"
context heap_base begin
lemma external_WT'_iff:
"P,h ⊢ a∙M(vs) : U ⟷
(∃hT Ts Ts' D. typeof_addr h a = ⌊hT⌋ ∧ map typeof⇘h⇙ vs = map Some Ts ∧ P ⊢ class_type_of hT sees M:Ts'→U=Native in D ∧ P ⊢ Ts [≤] Ts')"
by(simp add: external_WT'.simps)
end
context heap begin
lemma external_WT'_hext_mono:
"⟦ P,h ⊢ a∙M(vs) : T; h ⊴ h' ⟧ ⟹ P,h' ⊢ a∙M(vs) : T"
by(auto 5 2 simp add: external_WT'_iff dest: typeof_addr_hext_mono map_typeof_hext_mono)
end
subsection ‹Semantics of external calls›
datatype 'addr extCallRet =
RetVal "'addr val"
| RetExc 'addr
| RetStaySame
lemma rec_extCallRet [simp]: "rec_extCallRet = case_extCallRet"
by(auto simp add: fun_eq_iff split: extCallRet.split)
context heap_base begin
abbreviation RetEXC :: "cname ⇒ 'addr extCallRet"
where "RetEXC C ≡ RetExc (addr_of_sys_xcpt C)"
inductive heap_copy_loc :: "'addr ⇒ 'addr ⇒ addr_loc ⇒ 'heap ⇒ ('addr, 'thread_id) obs_event list ⇒ 'heap ⇒ bool"
for a :: 'addr and a' :: 'addr and al :: addr_loc and h :: 'heap
where
"⟦ heap_read h a al v; heap_write h a' al v h' ⟧
⟹ heap_copy_loc a a' al h ([ReadMem a al v, WriteMem a' al v]) h'"
inductive heap_copies :: "'addr ⇒ 'addr ⇒ addr_loc list ⇒ 'heap ⇒ ('addr, 'thread_id) obs_event list ⇒ 'heap ⇒ bool"
for a :: 'addr and a' :: 'addr
where
Nil: "heap_copies a a' [] h [] h"
| Cons:
"⟦ heap_copy_loc a a' al h ob h'; heap_copies a a' als h' obs h'' ⟧
⟹ heap_copies a a' (al # als) h (ob @ obs) h''"
inductive_cases heap_copies_cases:
"heap_copies a a' [] h ops h'"
"heap_copies a a' (al#als) h ops h'"
text ‹
Contrary to Sun's JVM 1.6.0\_07, cloning an interrupted thread does not yield an interrupted thread,
because the interrupt flag is not stored inside the thread object.
Starting a clone of a started thread with Sun JVM 1.6.0\_07 raises an illegal thread state exception,
we just start another thread.
The thread at @{url "http://mail.openjdk.java.net/pipermail/core-libs-dev/2010-August/004715.html"} discusses
the general problem of thread cloning and argues against that.
The bug report @{url "http://bugs.sun.com/bugdatabase/view_bug.do?bug_id=6968584"}
changes the Thread class implementation
such that \texttt{Object.clone()} can no longer be accessed for Thread and subclasses in Java 7.
Array cells are never volatile themselves.
›
inductive heap_clone :: "'m prog ⇒ 'heap ⇒ 'addr ⇒ 'heap ⇒ (('addr, 'thread_id) obs_event list × 'addr) option ⇒ bool"
for P :: "'m prog" and h :: 'heap and a :: 'addr
where
CloneFail:
"⟦ typeof_addr h a = ⌊hT⌋; allocate h hT = {} ⟧
⟹ heap_clone P h a h None"
| ObjClone:
"⟦ typeof_addr h a = ⌊Class_type C⌋; (h', a') ∈ allocate h (Class_type C);
P ⊢ C has_fields FDTs; heap_copies a a' (map (λ((F, D), Tfm). CField D F) FDTs) h' obs h'' ⟧
⟹ heap_clone P h a h'' ⌊(NewHeapElem a' (Class_type C) # obs, a')⌋"
| ArrClone:
"⟦ typeof_addr h a = ⌊Array_type T n⌋; (h', a') ∈ allocate h (Array_type T n); P ⊢ Object has_fields FDTs;
heap_copies a a' (map (λ((F, D), Tfm). CField D F) FDTs @ map ACell [0..<n]) h' obs h'' ⟧
⟹ heap_clone P h a h'' ⌊(NewHeapElem a' (Array_type T n) # obs, a')⌋"
inductive red_external ::
"'m prog ⇒ 'thread_id ⇒ 'heap ⇒ 'addr ⇒ mname ⇒ 'addr val list
⇒ ('addr, 'thread_id, 'heap) external_thread_action ⇒ 'addr extCallRet ⇒ 'heap ⇒ bool"
and red_external_syntax ::
"'m prog ⇒ 'thread_id ⇒ 'addr ⇒ mname ⇒ 'addr val list ⇒ 'heap
⇒ ('addr, 'thread_id, 'heap) external_thread_action ⇒ 'addr extCallRet ⇒ 'heap ⇒ bool"
("_,_ ⊢ (⟨(_∙_'(_')),/_⟩) -_→ext (⟨(_),/(_)⟩)" [50, 0, 0, 0, 0, 0, 0, 0, 0] 51)
for P :: "'m prog" and t :: 'thread_id and h :: 'heap and a :: 'addr
where
"P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩ ≡ red_external P t h a M vs ta va h'"
| RedNewThread:
"⟦ typeof_addr h a = ⌊Class_type C⌋; P ⊢ C ≼⇧* Thread ⟧
⟹ P,t ⊢ ⟨a∙start([]), h⟩ -⦃NewThread (addr2thread_id a) (C, run, a) h, ThreadStart (addr2thread_id a) ⦄→ext ⟨RetVal Unit, h⟩"
| RedNewThreadFail:
"⟦ typeof_addr h a = ⌊Class_type C⌋; P ⊢ C ≼⇧* Thread ⟧
⟹ P,t ⊢ ⟨a∙start([]), h⟩ -⦃ThreadExists (addr2thread_id a) True⦄→ext ⟨RetEXC IllegalThreadState, h⟩"
| RedJoin:
"⟦ typeof_addr h a = ⌊Class_type C⌋; P ⊢ C ≼⇧* Thread ⟧
⟹ P,t ⊢ ⟨a∙join([]), h⟩ -⦃Join (addr2thread_id a), IsInterrupted t False, ThreadJoin (addr2thread_id a)⦄→ext ⟨RetVal Unit, h⟩"
| RedJoinInterrupt:
"⟦ typeof_addr h a = ⌊Class_type C⌋; P ⊢ C ≼⇧* Thread ⟧
⟹ P,t ⊢ ⟨a∙join([]), h⟩ -⦃IsInterrupted t True, ClearInterrupt t, ObsInterrupted t⦄→ext ⟨RetEXC InterruptedException, h⟩"
| RedInterrupt:
"⟦ typeof_addr h a = ⌊Class_type C⌋; P ⊢ C ≼⇧* Thread ⟧
⟹ P,t ⊢ ⟨a∙interrupt([]), h⟩
-⦃ThreadExists (addr2thread_id a) True, WakeUp (addr2thread_id a),
Interrupt (addr2thread_id a), ObsInterrupt (addr2thread_id a)⦄→ext
⟨RetVal Unit, h⟩"
| RedInterruptInexist:
"⟦ typeof_addr h a = ⌊Class_type C⌋; P ⊢ C ≼⇧* Thread ⟧
⟹ P,t ⊢ ⟨a∙interrupt([]), h⟩
-⦃ThreadExists (addr2thread_id a) False⦄→ext
⟨RetVal Unit, h⟩"
| RedIsInterruptedTrue:
"⟦ typeof_addr h a = ⌊Class_type C⌋; P ⊢ C ≼⇧* Thread ⟧
⟹ P,t ⊢ ⟨a∙isInterrupted([]), h⟩ -⦃ IsInterrupted (addr2thread_id a) True, ObsInterrupted (addr2thread_id a)⦄→ext
⟨RetVal (Bool True), h⟩"
| RedIsInterruptedFalse:
"⟦ typeof_addr h a = ⌊Class_type C⌋; P ⊢ C ≼⇧* Thread ⟧
⟹ P,t ⊢ ⟨a∙isInterrupted([]), h⟩ -⦃IsInterrupted (addr2thread_id a) False⦄→ext ⟨RetVal (Bool False), h⟩"
| RedWaitInterrupt:
"P,t ⊢ ⟨a∙wait([]), h⟩ -⦃Unlock→a, Lock→a, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t⦄ →ext
⟨RetEXC InterruptedException, h⟩"
| RedWait:
"P,t ⊢ ⟨a∙wait([]), h⟩ -⦃Suspend a, Unlock→a, Lock→a, ReleaseAcquire→a, IsInterrupted t False, SyncUnlock a ⦄→ext
⟨RetStaySame, h⟩"
| RedWaitFail:
"P,t ⊢ ⟨a∙wait([]), h⟩ -⦃UnlockFail→a⦄→ext ⟨RetEXC IllegalMonitorState, h⟩"
| RedWaitNotified:
"P,t ⊢ ⟨a∙wait([]), h⟩ -⦃Notified⦄→ext ⟨RetVal Unit, h⟩"
| RedWaitInterrupted:
"P,t ⊢ ⟨a∙wait([]), h⟩ -⦃WokenUp, ClearInterrupt t, ObsInterrupted t⦄→ext ⟨RetEXC InterruptedException, h⟩"
| RedWaitSpurious:
"spurious_wakeups ⟹
P,t ⊢ ⟨a∙wait([]), h⟩ -⦃Unlock→a, Lock→a, ReleaseAcquire→a, IsInterrupted t False, SyncUnlock a⦄ →ext
⟨RetVal Unit, h⟩"
| RedNotify:
"P,t ⊢ ⟨a∙notify([]), h⟩ -⦃Notify a, Unlock→a, Lock→a⦄→ext ⟨RetVal Unit, h⟩"
| RedNotifyFail:
"P,t ⊢ ⟨a∙notify([]), h⟩ -⦃UnlockFail→a⦄→ext ⟨RetEXC IllegalMonitorState, h⟩"
| RedNotifyAll:
"P,t ⊢ ⟨a∙notifyAll([]), h⟩ -⦃NotifyAll a, Unlock→a, Lock→a⦄→ext ⟨RetVal Unit, h⟩"
| RedNotifyAllFail:
"P,t ⊢ ⟨a∙notifyAll([]), h⟩ -⦃UnlockFail→a⦄→ext ⟨RetEXC IllegalMonitorState, h⟩"
| RedClone:
"heap_clone P h a h' ⌊(obs, a')⌋
⟹ P,t ⊢ ⟨a∙clone([]), h⟩ -(K$ [], [], [], [], [], obs)→ext ⟨RetVal (Addr a'), h'⟩"
| RedCloneFail:
"heap_clone P h a h' None ⟹ P,t ⊢ ⟨a∙clone([]), h⟩ -ε→ext ⟨RetEXC OutOfMemory, h'⟩"
| RedHashcode:
"P,t ⊢ ⟨a∙hashcode([]), h⟩ -⦃⦄→ext ⟨RetVal (Intg (word_of_int (hash_addr a))), h⟩"
| RedPrint:
"P,t ⊢ ⟨a∙print(vs), h⟩ -⦃ExternalCall a print vs Unit⦄→ext ⟨RetVal Unit, h⟩"
| RedCurrentThread:
"P,t ⊢ ⟨a∙currentThread([]), h⟩ -⦃⦄→ext ⟨RetVal (Addr (thread_id2addr t)), h⟩"
| RedInterruptedTrue:
"P,t ⊢ ⟨a∙interrupted([]), h⟩ -⦃IsInterrupted t True, ClearInterrupt t, ObsInterrupted t⦄→ext ⟨RetVal (Bool True), h⟩"
| RedInterruptedFalse:
"P,t ⊢ ⟨a∙interrupted([]), h⟩ -⦃IsInterrupted t False⦄→ext ⟨RetVal (Bool False), h⟩"
| RedYield:
"P,t ⊢ ⟨a∙yield([]), h⟩ -⦃Yield⦄→ext ⟨RetVal Unit, h⟩"
subsection ‹Aggressive formulation for external cals›
definition red_external_aggr ::
"'m prog ⇒ 'thread_id ⇒ 'addr ⇒ mname ⇒ 'addr val list ⇒ 'heap ⇒
(('addr, 'thread_id, 'heap) external_thread_action × 'addr extCallRet × 'heap) set"
where
"red_external_aggr P t a M vs h =
(if M = wait then
let ad_t = thread_id2addr t
in {(⦃Unlock→a, Lock→a, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t⦄, RetEXC InterruptedException, h),
(⦃Suspend a, Unlock→a, Lock→a, ReleaseAcquire→a, IsInterrupted t False, SyncUnlock a⦄, RetStaySame, h),
(⦃UnlockFail→a⦄, RetEXC IllegalMonitorState, h),
(⦃Notified⦄, RetVal Unit, h),
(⦃WokenUp, ClearInterrupt t, ObsInterrupted t⦄, RetEXC InterruptedException, h)} ∪
(if spurious_wakeups then {(⦃Unlock→a, Lock→a, ReleaseAcquire→a, IsInterrupted t False, SyncUnlock a⦄, RetVal Unit, h)} else {})
else if M = notify then {(⦃Notify a, Unlock→a, Lock→a⦄, RetVal Unit, h),
(⦃UnlockFail→a⦄, RetEXC IllegalMonitorState, h)}
else if M = notifyAll then {(⦃NotifyAll a, Unlock→a, Lock→a ⦄, RetVal Unit, h),
(⦃UnlockFail→a⦄, RetEXC IllegalMonitorState, h)}
else if M = clone then
{((K$ [], [], [], [], [], obs), RetVal (Addr a'), h')|obs a' h'. heap_clone P h a h' ⌊(obs, a')⌋}
∪ {(⦃⦄, RetEXC OutOfMemory, h')|h'. heap_clone P h a h' None}
else if M = hashcode then {(⦃⦄, RetVal (Intg (word_of_int (hash_addr a))), h)}
else if M = print then {(⦃ExternalCall a M vs Unit⦄, RetVal Unit, h)}
else if M = currentThread then {(⦃⦄, RetVal (Addr (thread_id2addr t)), h)}
else if M = interrupted then {(⦃IsInterrupted t True, ClearInterrupt t, ObsInterrupted t⦄, RetVal (Bool True), h),
(⦃IsInterrupted t False⦄, RetVal (Bool False), h)}
else if M = yield then {(⦃Yield⦄, RetVal Unit, h)}
else
let hT = the (typeof_addr h a)
in if P ⊢ ty_of_htype hT ≤ Class Thread then
let t_a = addr2thread_id a
in if M = start then
{(⦃NewThread t_a (the_Class (ty_of_htype hT), run, a) h, ThreadStart t_a⦄, RetVal Unit, h),
(⦃ThreadExists t_a True⦄, RetEXC IllegalThreadState, h)}
else if M = join then
{(⦃Join t_a, IsInterrupted t False, ThreadJoin t_a⦄, RetVal Unit, h),
(⦃IsInterrupted t True, ClearInterrupt t, ObsInterrupted t⦄, RetEXC InterruptedException, h)}
else if M = interrupt then
{(⦃ThreadExists t_a True, WakeUp t_a, Interrupt t_a, ObsInterrupt t_a⦄, RetVal Unit, h),
(⦃ThreadExists t_a False⦄, RetVal Unit, h)}
else if M = isInterrupted then
{(⦃IsInterrupted t_a False⦄, RetVal (Bool False), h),
(⦃IsInterrupted t_a True, ObsInterrupted t_a⦄, RetVal (Bool True), h)}
else {(⦃⦄, undefined)}
else {(⦃⦄, undefined)})"
lemma red_external_imp_red_external_aggr:
"P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩ ⟹ (ta, va, h') ∈ red_external_aggr P t a M vs h"
unfolding red_external_aggr_def
by(auto elim!: red_external.cases split del: if_split simp add: split_beta)
end
context heap begin
lemma hext_heap_copy_loc:
"heap_copy_loc a a' al h obs h' ⟹ h ⊴ h'"
by(blast elim: heap_copy_loc.cases dest: hext_heap_ops)
lemma hext_heap_copies:
assumes "heap_copies a a' als h obs h'"
shows "h ⊴ h'"
using assms by induct(blast intro: hext_heap_copy_loc hext_trans)+
lemma hext_heap_clone:
assumes "heap_clone P h a h' res"
shows "h ⊴ h'"
using assms by(blast elim: heap_clone.cases dest: hext_heap_ops hext_heap_copies intro: hext_trans)
theorem red_external_hext:
assumes "P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩"
shows "hext h h'"
using assms
by(cases)(blast intro: hext_heap_ops hext_heap_clone)+
lemma red_external_preserves_tconf:
"⟦ P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩; P,h ⊢ t' √t ⟧ ⟹ P,h' ⊢ t' √t"
by(drule red_external_hext)(rule tconf_hext_mono)
end
context heap_conf begin
lemma typeof_addr_heap_clone:
assumes "heap_clone P h a h' ⌊(obs, a')⌋"
and "hconf h"
shows "typeof_addr h' a' = typeof_addr h a"
using assms
by cases (auto dest!: allocate_SomeD hext_heap_copies dest: typeof_addr_hext_mono typeof_addr_is_type is_type_ArrayD)
end
context heap_base begin
lemma red_ext_new_thread_heap:
"⟦ P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩; NewThread t' ex h'' ∈ set ⦃ta⦄⇘t⇙ ⟧ ⟹ h'' = h'"
by(auto elim: red_external.cases simp add: ta_upd_simps)
lemma red_ext_aggr_new_thread_heap:
"⟦ (ta, va, h') ∈ red_external_aggr P t a M vs h; NewThread t' ex h'' ∈ set ⦃ta⦄⇘t⇙ ⟧ ⟹ h'' = h'"
by(auto simp add: red_external_aggr_def is_native.simps split_beta ta_upd_simps split: if_split_asm)
end
context addr_conv begin
lemma red_external_new_thread_exists_thread_object:
"⟦ P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩; NewThread t' x h'' ∈ set ⦃ta⦄⇘t⇙ ⟧
⟹ ∃C. typeof_addr h' (thread_id2addr t') = ⌊Class_type C⌋ ∧ P ⊢ C ≼⇧* Thread"
by(auto elim!: red_external.cases dest!: Array_widen simp add: ta_upd_simps)
lemma red_external_aggr_new_thread_exists_thread_object:
"⟦ (ta, va, h') ∈ red_external_aggr P t a M vs h; typeof_addr h a ≠ None;
NewThread t' x h'' ∈ set ⦃ta⦄⇘t⇙ ⟧
⟹ ∃C. typeof_addr h' (thread_id2addr t') = ⌊Class_type C⌋ ∧ P ⊢ C ≼⇧* Thread"
by(auto simp add: red_external_aggr_def is_native.simps split_beta ta_upd_simps widen_Class split: if_split_asm dest!: Array_widen)
end
context heap begin
lemma red_external_aggr_hext:
"⟦ (ta, va, h') ∈ red_external_aggr P t a M vs h; is_native P (the (typeof_addr h a)) M ⟧ ⟹ h ⊴ h'"
apply(auto simp add: red_external_aggr_def split_beta is_native.simps elim!: external_WT_defs_cases hext_heap_clone split: if_split_asm)
apply(auto elim!: external_WT_defs.cases dest!: sees_method_decl_above intro: widen_trans simp add: class_type_of_eq split: htype.split_asm)
done
lemma red_external_aggr_preserves_tconf:
"⟦ (ta, va, h') ∈ red_external_aggr P t a M vs h; is_native P (the (typeof_addr h a)) M; P,h ⊢ t' √t ⟧
⟹ P,h' ⊢ t' √t"
by(blast dest: red_external_aggr_hext intro: tconf_hext_mono)
end
context heap_base begin
lemma red_external_Wakeup_no_Join_no_Lock_no_Interrupt:
"⟦ P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩; Notified ∈ set ⦃ta⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta⦄⇘w⇙ ⟧ ⟹
collect_locks ⦃ta⦄⇘l⇙ = {} ∧ collect_cond_actions ⦃ta⦄⇘c⇙ = {} ∧ collect_interrupts ⦃ta⦄⇘i⇙ = {}"
by(auto elim!: red_external.cases simp add: ta_upd_simps collect_locks_def collect_interrupts_def)
lemma red_external_aggr_Wakeup_no_Join:
"⟦ (ta, va, h') ∈ red_external_aggr P t a M vs h;
Notified ∈ set ⦃ta⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta⦄⇘w⇙ ⟧
⟹ collect_locks ⦃ta⦄⇘l⇙ = {} ∧ collect_cond_actions ⦃ta⦄⇘c⇙ = {} ∧ collect_interrupts ⦃ta⦄⇘i⇙ = {}"
by(auto simp add: red_external_aggr_def split_beta ta_upd_simps collect_locks_def collect_interrupts_def split: if_split_asm)
lemma red_external_Suspend_StaySame:
"⟦ P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩; Suspend w ∈ set ⦃ta⦄⇘w⇙ ⟧ ⟹ va = RetStaySame"
by(auto elim!: red_external.cases simp add: ta_upd_simps)
lemma red_external_aggr_Suspend_StaySame:
"⟦ (ta, va, h') ∈ red_external_aggr P t a M vs h; Suspend w ∈ set ⦃ta⦄⇘w⇙ ⟧ ⟹ va = RetStaySame"
by(auto simp add: red_external_aggr_def split_beta ta_upd_simps split: if_split_asm)
lemma red_external_Suspend_waitD:
"⟦ P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩; Suspend w ∈ set ⦃ta⦄⇘w⇙ ⟧ ⟹ M = wait"
by(auto elim!: red_external.cases simp add: ta_upd_simps)
lemma red_external_aggr_Suspend_waitD:
"⟦ (ta, va, h') ∈ red_external_aggr P t a M vs h; Suspend w ∈ set ⦃ta⦄⇘w⇙ ⟧ ⟹ M = wait"
by(auto simp add: red_external_aggr_def split_beta ta_upd_simps split: if_split_asm)
lemma red_external_new_thread_sub_thread:
"⟦ P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩; NewThread t' (C, M', a') h'' ∈ set ⦃ta⦄⇘t⇙ ⟧
⟹ typeof_addr h' a' = ⌊Class_type C⌋ ∧ P ⊢ C ≼⇧* Thread ∧ M' = run"
by(auto elim!: red_external.cases simp add: widen_Class ta_upd_simps)
lemma red_external_aggr_new_thread_sub_thread:
"⟦ (ta, va, h') ∈ red_external_aggr P t a M vs h; typeof_addr h a ≠ None;
NewThread t' (C, M', a') h'' ∈ set ⦃ta⦄⇘t⇙ ⟧
⟹ typeof_addr h' a' = ⌊Class_type C⌋ ∧ P ⊢ C ≼⇧* Thread ∧ M' = run"
by(auto simp add: red_external_aggr_def split_beta ta_upd_simps widen_Class split: if_split_asm dest!: Array_widen)
lemma heap_copy_loc_length:
assumes "heap_copy_loc a a' al h obs h'"
shows "length obs = 2"
using assms by(cases) simp
lemma heap_copies_length:
assumes "heap_copies a a' als h obs h'"
shows "length obs = 2 * length als"
using assms by(induct)(auto dest!: heap_copy_loc_length)
end
subsection ‹‹τ›-moves›
inductive τexternal_defs :: "cname ⇒ mname ⇒ bool"
where
"τexternal_defs Object hashcode"
| "τexternal_defs Object currentThread"
definition τexternal :: "'m prog ⇒ htype ⇒ mname ⇒ bool"
where "τexternal P hT M ⟷ (∃Ts Tr D. P ⊢ class_type_of hT sees M:Ts→Tr = Native in D ∧ τexternal_defs D M)"
context heap_base begin
definition τexternal' :: "'m prog ⇒ 'heap ⇒ 'addr ⇒ mname ⇒ bool"
where "τexternal' P h a M ⟷ (∃hT. typeof_addr h a = Some hT ∧ τexternal P hT M)"
lemma τexternal'_red_external_heap_unchanged:
"⟦ P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩; τexternal' P h a M ⟧ ⟹ h' = h"
by(auto elim!: red_external.cases τexternal_defs.cases simp add: τexternal_def τexternal'_def)
lemma τexternal'_red_external_aggr_heap_unchanged:
"⟦ (ta, va, h') ∈ red_external_aggr P t a M vs h; τexternal' P h a M ⟧ ⟹ h' = h"
by(auto elim!: τexternal_defs.cases simp add: τexternal_def τexternal'_def red_external_aggr_def)
lemma τexternal'_red_external_TA_empty:
"⟦ P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩; τexternal' P h a M ⟧ ⟹ ta = ε"
by(auto elim!: red_external.cases τexternal_defs.cases simp add: τexternal_def τexternal'_def)
lemma τexternal'_red_external_aggr_TA_empty:
"⟦ (ta, va, h') ∈ red_external_aggr P t a M vs h; τexternal' P h a M ⟧ ⟹ ta = ε"
by(auto elim!: τexternal_defs.cases simp add: τexternal_def τexternal'_def red_external_aggr_def)
lemma red_external_new_thread_addr_conf:
"⟦ P,t ⊢ ⟨a∙M(vs),h⟩ -ta→ext ⟨va,h'⟩; NewThread t (C, M, a') h'' ∈ set ⦃ta⦄⇘t⇙ ⟧
⟹ P,h' ⊢ Addr a :≤ Class Thread"
by(auto elim!: red_external.cases simp add: conf_def ta_upd_simps)
lemma τexternal_red_external_aggr_heap_unchanged:
"⟦ (ta, va, h') ∈ red_external_aggr P t a M vs h; τexternal P (the (typeof_addr h a)) M ⟧ ⟹ h' = h"
by(auto elim!: τexternal_defs.cases simp add: τexternal_def red_external_aggr_def)
lemma τexternal_red_external_aggr_TA_empty:
"⟦ (ta, va, h') ∈ red_external_aggr P t a M vs h; τexternal P (the (typeof_addr h a)) M ⟧ ⟹ ta = ε"
by(auto elim!: τexternal_defs.cases simp add: τexternal_def red_external_aggr_def)
end
subsection ‹Code generation›
code_pred
(modes:
i ⇒ i ⇒ i ⇒ i ⇒ bool,
i ⇒ i ⇒ i ⇒ o ⇒ bool,
i ⇒ i ⇒ o ⇒ o ⇒ bool,
o ⇒ i ⇒ o ⇒ o ⇒ bool)
external_WT_defs
.
code_pred
(modes: i ⇒ i ⇒ i ⇒ bool)
[inductify, skip_proof]
is_native
.
declare heap_base.heap_copy_loc.intros[code_pred_intro]
code_pred
(modes: (i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ (i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ bool)
heap_base.heap_copy_loc
proof -
case heap_copy_loc
from heap_copy_loc.prems show thesis
by(rule heap_base.heap_copy_loc.cases)(rule heap_copy_loc.that[OF refl refl refl refl refl refl])
qed
declare heap_base.heap_copies.intros [code_pred_intro]
code_pred
(modes: (i ⇒ i ⇒ i ⇒ o ⇒ bool) => (i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ bool)
heap_base.heap_copies
proof -
case heap_copies
from heap_copies.prems show thesis
by(rule heap_base.heap_copies.cases)(erule (3) heap_copies.that[OF refl refl refl refl]|assumption)+
qed
declare heap_base.heap_clone.intros [folded Predicate_Compile.contains_def, code_pred_intro]
code_pred
(modes: i ⇒ i ⇒ (i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ (i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ bool)
heap_base.heap_clone
proof -
case heap_clone
from heap_clone.prems show thesis
by(rule heap_base.heap_clone.cases[folded Predicate_Compile.contains_def])(erule (3) heap_clone.that[OF refl refl refl refl refl refl refl]|assumption)+
qed
text ‹
code\_pred in Isabelle2012 cannot handle boolean parameters as premises properly,
so this replacement rule explicitly tests for @{term "True"}
›
lemma (in heap_base) RedWaitSpurious_Code:
"spurious_wakeups = True ⟹
P,t ⊢ ⟨a∙wait([]),h⟩ -⦃Unlock→a, Lock→a, ReleaseAcquire→a, IsInterrupted t False, SyncUnlock a⦄→ext ⟨RetVal Unit,h⟩"
by(rule RedWaitSpurious) simp
lemmas [code_pred_intro] =
heap_base.RedNewThread heap_base.RedNewThreadFail
heap_base.RedJoin heap_base.RedJoinInterrupt
heap_base.RedInterrupt heap_base.RedInterruptInexist heap_base.RedIsInterruptedTrue heap_base.RedIsInterruptedFalse
heap_base.RedWaitInterrupt heap_base.RedWait heap_base.RedWaitFail heap_base.RedWaitNotified heap_base.RedWaitInterrupted
declare heap_base.RedWaitSpurious_Code [code_pred_intro RedWaitSpurious]
lemmas [code_pred_intro] =
heap_base.RedNotify heap_base.RedNotifyFail heap_base.RedNotifyAll heap_base.RedNotifyAllFail
heap_base.RedClone heap_base.RedCloneFail
heap_base.RedHashcode heap_base.RedPrint heap_base.RedCurrentThread
heap_base.RedInterruptedTrue heap_base.RedInterruptedFalse
heap_base.RedYield
code_pred
(modes: i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ (i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ (i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ o ⇒ bool)
heap_base.red_external
proof -
case red_external
from red_external.prems show ?thesis
apply(rule heap_base.red_external.cases)
apply(erule (4) red_external.that[OF refl refl refl refl refl refl refl refl refl refl refl refl]|assumption|erule eqTrueI)+
done
qed
end
Theory WellForm
section ‹Generic Well-formedness of programs›
theory WellForm
imports
SystemClasses
ExternalCall
begin
text ‹\noindent This theory defines global well-formedness conditions
for programs but does not look inside method bodies. Hence it works
for both Jinja and JVM programs. Well-typing of expressions is defined
elsewhere (in theory ‹WellType›).
Because JinjaThreads does not have method overloading, its policy for method
overriding is the classical one: \emph{covariant in the result type
but contravariant in the argument types.} This means the result type
of the overriding method becomes more specific, the argument types
become more general.
›
type_synonym 'm wf_mdecl_test = "'m prog ⇒ cname ⇒ 'm mdecl ⇒ bool"
definition wf_fdecl :: "'m prog ⇒ fdecl ⇒ bool"
where "wf_fdecl P ≡ λ(F,T,fm). is_type P T"
definition wf_mdecl :: "'m wf_mdecl_test ⇒ 'm prog ⇒ cname ⇒ 'm mdecl' ⇒ bool" where
"wf_mdecl wf_md P C ≡
λ(M,Ts,T,m). (∀T∈set Ts. is_type P T) ∧ is_type P T ∧
(case m of Native ⇒ C∙M(Ts) :: T | ⌊mb⌋ ⇒ wf_md P C (M,Ts,T,mb))"
fun wf_overriding :: "'m prog ⇒ cname ⇒ 'm mdecl' ⇒ bool"
where
"wf_overriding P D (M,Ts,T,m) =
(∀D' Ts' T' m'. P ⊢ D sees M:Ts' → T' = m' in D' ⟶ P ⊢ Ts' [≤] Ts ∧ P ⊢ T ≤ T')"
definition wf_cdecl :: "'m wf_mdecl_test ⇒ 'm prog ⇒ 'm cdecl ⇒ bool"
where
"wf_cdecl wf_md P ≡ λ(C,(D,fs,ms)).
(∀f∈set fs. wf_fdecl P f) ∧ distinct_fst fs ∧
(∀m∈set ms. wf_mdecl wf_md P C m) ∧
distinct_fst ms ∧
(C ≠ Object ⟶
is_class P D ∧ ¬ P ⊢ D ≼⇧* C ∧
(∀m∈set ms. wf_overriding P D m)) ∧
(C = Thread ⟶ (∃m. (run, [], Void, m) ∈ set ms))"
definition wf_prog :: "'m wf_mdecl_test ⇒ 'm prog ⇒ bool"
where
"wf_prog wf_md P ⟷ wf_syscls P ∧ distinct_fst (classes P) ∧ (∀c ∈ set (classes P). wf_cdecl wf_md P c)"
lemma wf_prog_def2:
"wf_prog wf_md P ⟷ wf_syscls P ∧ (∀C rest. class P C = ⌊rest⌋ ⟶ wf_cdecl wf_md P (C, rest)) ∧ distinct_fst (classes P)"
by(cases P)(auto simp add: wf_prog_def dest: map_of_SomeD map_of_SomeI)
subsection‹Well-formedness lemmas›
lemma wf_prog_wf_syscls: "wf_prog wf_md P ⟹ wf_syscls P"
by(simp add: wf_prog_def)
lemma class_wf:
"⟦class P C = Some c; wf_prog wf_md P⟧ ⟹ wf_cdecl wf_md P (C,c)"
by (cases P) (fastforce dest: map_of_SomeD simp add: wf_prog_def)
lemma [simp]:
assumes "wf_prog wf_md P"
shows class_Object: "∃C fs ms. class P Object = Some (C,fs,ms)"
and class_Thread: "∃C fs ms. class P Thread = Some (C,fs,ms)"
using wf_prog_wf_syscls[OF assms]
by(rule wf_syscls_class_Object wf_syscls_class_Thread)+
lemma [simp]:
assumes "wf_prog wf_md P"
shows is_class_Object: "is_class P Object"
and is_class_Thread: "is_class P Thread"
using wf_prog_wf_syscls[OF assms] by simp_all
lemma xcpt_subcls_Throwable:
"⟦ C ∈ sys_xcpts; wf_prog wf_md P ⟧ ⟹ P ⊢ C ≼⇧* Throwable"
by(simp add: wf_prog_wf_syscls wf_syscls_xcpt_subcls_Throwable)
lemma is_class_Throwable:
"wf_prog wf_md P ⟹ is_class P Throwable"
by(rule wf_prog_wf_syscls wf_syscls_is_class_Throwable)+
lemma is_class_sub_Throwable:
"⟦ wf_prog wf_md P; P ⊢ C ≼⇧* Throwable ⟧ ⟹ is_class P C"
by(rule wf_syscls_is_class_sub_Throwable[OF wf_prog_wf_syscls])
lemma is_class_xcpt:
"⟦ C ∈ sys_xcpts; wf_prog wf_md P ⟧ ⟹ is_class P C"
by(rule wf_syscls_is_class_xcpt[OF _ wf_prog_wf_syscls])
context heap_base begin
lemma wf_preallocatedE:
assumes "wf_prog wf_md P"
and "preallocated h"
and "C ∈ sys_xcpts"
obtains "typeof_addr h (addr_of_sys_xcpt C) = ⌊Class_type C⌋" "P ⊢ C ≼⇧* Throwable"
proof -
from ‹preallocated h› ‹C ∈ sys_xcpts› have "typeof_addr h (addr_of_sys_xcpt C) = ⌊Class_type C⌋"
by(rule typeof_addr_sys_xcp)
moreover from ‹C ∈ sys_xcpts› ‹wf_prog wf_md P› have "P ⊢ C ≼⇧* Throwable" by(rule xcpt_subcls_Throwable)
ultimately show thesis by(rule that)
qed
lemma wf_preallocatedD:
assumes "wf_prog wf_md P"
and "preallocated h"
and "C ∈ sys_xcpts"
shows "typeof_addr h (addr_of_sys_xcpt C) = ⌊Class_type C⌋ ∧ P ⊢ C ≼⇧* Throwable"
using assms
by(rule wf_preallocatedE) blast
end
lemma (in heap_conf) hconf_start_heap:
"wf_prog wf_md P ⟹ hconf start_heap"
unfolding start_heap_def start_heap_data_def initialization_list_def sys_xcpts_list_def
using hconf_empty
by -(simp add: create_initial_object_simps del: hconf_empty, clarsimp split: prod.split elim!: not_empty_pairE simp del: hconf_empty, drule (1) allocate_Eps, drule (1) hconf_allocate_mono, simp add: is_class_xcpt)+
lemma subcls1_wfD:
"⟦ P ⊢ C ≺⇧1 D; wf_prog wf_md P ⟧ ⟹ D ≠ C ∧ ¬ (subcls1 P)⇧+⇧+ D C"
apply( frule tranclp.r_into_trancl[where r="subcls1 P"])
apply( drule subcls1D)
apply(clarify)
apply( drule (1) class_wf)
apply( unfold wf_cdecl_def)
apply(rule conjI)
apply(force)
apply(unfold reflclp_tranclp[symmetric, where r="subcls1 P"])
apply(blast)
done
lemma wf_cdecl_supD:
"⟦wf_cdecl wf_md P (C,D,r); C ≠ Object⟧ ⟹ is_class P D"
by (auto simp: wf_cdecl_def)
lemma subcls_asym:
"⟦ wf_prog wf_md P; (subcls1 P)⇧+⇧+ C D ⟧ ⟹ ¬ (subcls1 P)⇧+⇧+ D C"
apply(erule tranclp.cases)
apply(fast dest!: subcls1_wfD )
apply(fast dest!: subcls1_wfD intro: tranclp_trans)
done
lemma subcls_irrefl:
"⟦ wf_prog wf_md P; (subcls1 P)⇧+⇧+ C D⟧ ⟹ C ≠ D"
apply (erule tranclp_trans_induct)
apply (auto dest: subcls1_wfD subcls_asym)
done
lemma acyclicP_def:
"acyclicP r ⟷ (∀x. ¬ r^++ x x)"
unfolding acyclic_def trancl_def
by(auto)
lemma acyclic_subcls1:
"wf_prog wf_md P ⟹ acyclicP (subcls1 P)"
by(unfold acyclicP_def)(fast dest: subcls_irrefl)
lemma finite_conversep: "finite {(x, y). r¯¯ x y} = finite {(x, y). r x y}"
by(subst finite_converse[unfolded converse_unfold, symmetric]) simp
lemma acyclicP_wf_subcls1:
"acyclicP (subcls1 P) ⟹ wfP ((subcls1 P)¯¯)"
unfolding wfP_def
by(rule finite_acyclic_wf)(simp_all only: finite_conversep finite_subcls1 acyclicP_converse)
lemma wf_subcls1:
"wf_prog wf_md P ⟹ wfP ((subcls1 P)¯¯)"
by(rule acyclicP_wf_subcls1)(rule acyclic_subcls1)
lemma single_valued_subcls1:
"wf_prog wf_md G ⟹ single_valuedp (subcls1 G)"
by(auto simp:wf_prog_def distinct_fst_def single_valuedp_def dest!:subcls1D)
lemma subcls_induct:
"⟦ wf_prog wf_md P; ⋀C. ∀D. (subcls1 P)⇧+⇧+ C D ⟶ Q D ⟹ Q C ⟧ ⟹ Q C"
(is "?A ⟹ PROP ?P ⟹ _")
proof -
assume p: "PROP ?P"
assume ?A thus ?thesis apply -
apply(drule wf_subcls1)
apply(drule wfP_trancl)
apply(simp only: tranclp_converse)
apply(erule_tac a = C in wfP_induct)
apply(rule p)
apply(auto)
done
qed
lemma subcls1_induct_aux:
"⟦ is_class P C; wf_prog wf_md P; Q Object;
⋀C D fs ms.
⟦ C ≠ Object; is_class P C; class P C = Some (D,fs,ms) ∧
wf_cdecl wf_md P (C,D,fs,ms) ∧ P ⊢ C ≺⇧1 D ∧ is_class P D ∧ Q D⟧ ⟹ Q C ⟧
⟹ Q C"
(is "?A ⟹ ?B ⟹ ?C ⟹ PROP ?P ⟹ _")
proof -
assume p: "PROP ?P"
assume ?A ?B ?C thus ?thesis apply -
apply(unfold is_class_def)
apply( rule impE)
prefer 2
apply( assumption)
prefer 2
apply( assumption)
apply( erule thin_rl)
apply( rule subcls_induct)
apply( assumption)
apply( rule impI)
apply( case_tac "C = Object")
apply( fast)
apply safe
apply( frule (1) class_wf)
apply( frule (1) wf_cdecl_supD)
apply( subgoal_tac "P ⊢ C ≺⇧1 a")
apply( erule_tac [2] subcls1I)
apply( rule p)
apply (unfold is_class_def)
apply auto
done
qed
lemma subcls1_induct [consumes 2, case_names Object Subcls]:
"⟦ wf_prog wf_md P; is_class P C; Q Object;
⋀C D. ⟦C ≠ Object; P ⊢ C ≺⇧1 D; is_class P D; Q D⟧ ⟹ Q C ⟧
⟹ Q C"
apply (erule subcls1_induct_aux, assumption, assumption)
apply blast
done
lemma subcls_C_Object:
"⟦ is_class P C; wf_prog wf_md P ⟧ ⟹ P ⊢ C ≼⇧* Object"
apply(erule (1) subcls1_induct)
apply( fast)
apply(erule (1) converse_rtranclp_into_rtranclp)
done
lemma converse_subcls_is_class:
assumes wf: "wf_prog wf_md P"
shows "⟦ P ⊢ C ≼⇧* D; is_class P C ⟧ ⟹ is_class P D"
proof(induct rule: rtranclp_induct)
assume "is_class P C"
thus "is_class P C" .
next
fix D E
assume PDE: "P ⊢ D ≺⇧1 E"
and IH: "is_class P C ⟹ is_class P D"
and iPC: "is_class P C"
have "is_class P D" by (rule IH[OF iPC])
with PDE obtain fsD MsD where classD: "class P D = ⌊(E, fsD, MsD)⌋"
by(auto simp add: is_class_def elim!: subcls1.cases)
thus "is_class P E" using wf PDE
by(auto elim!: subcls1.cases dest: class_wf simp: wf_cdecl_def)
qed
lemma is_class_is_subcls:
"wf_prog m P ⟹ is_class P C = P ⊢ C ≼⇧* Object"
by (fastforce simp:is_class_def
elim: subcls_C_Object converse_rtranclpE subcls1I
dest: subcls1D)
lemma subcls_antisym:
"⟦wf_prog m P; P ⊢ C ≼⇧* D; P ⊢ D ≼⇧* C⟧ ⟹ C = D"
apply(drule acyclic_subcls1)
apply(drule acyclic_impl_antisym_rtrancl)
apply(drule antisymD)
apply(unfold Transitive_Closure.rtrancl_def)
apply(auto)
done
lemma is_type_pTs:
"⟦ wf_prog wf_md P; class P C = ⌊(S,fs,ms)⌋; (M,Ts,T,m) ∈ set ms ⟧ ⟹ set Ts ⊆ types P"
by(fastforce dest: class_wf simp add: wf_cdecl_def wf_mdecl_def)
lemma widen_asym_1:
assumes wfP: "wf_prog wf_md P"
shows "P ⊢ C ≤ D ⟹ C = D ∨ ¬ (P ⊢ D ≤ C)"
proof (erule widen.induct)
fix T
show "T = T ∨ ¬ (P ⊢ T ≤ T)" by simp
next
fix C D
assume CscD: "P ⊢ C ≼⇧* D"
then have CpscD: "C = D ∨ (C ≠ D ∧ (subcls1 P)⇧+⇧+ C D)" by (simp add: rtranclpD)
{ assume "P ⊢ D ≼⇧* C"
then have DpscC: "D = C ∨ (D ≠ C ∧ (subcls1 P)⇧+⇧+ D C)" by (simp add: rtranclpD)
{ assume "(subcls1 P)⇧+⇧+ D C"
with wfP have CnscD: "¬ (subcls1 P)⇧+⇧+ C D" by (rule subcls_asym)
with CpscD have "C = D" by simp
}
with DpscC have "C = D" by blast
}
hence "Class C = Class D ∨ ¬ (P ⊢ D ≼⇧* C)" by blast
thus "Class C = Class D ∨ ¬ P ⊢ Class D ≤ Class C" by simp
next
fix C
show "NT = Class C ∨ ¬ P ⊢ Class C ≤ NT" by simp
next
fix A
{ assume "P ⊢ A⌊⌉ ≤ NT"
hence "A⌊⌉ = NT" by fastforce
hence "False" by simp }
hence "¬ (P ⊢ A⌊⌉ ≤ NT)" by blast
thus "NT = A⌊⌉ ∨ ¬ P ⊢ A⌊⌉ ≤ NT" by simp
next
fix A
show "A⌊⌉ = Class Object ∨ ¬ P ⊢ Class Object ≤ A⌊⌉"
by(auto dest: Object_widen)
next
fix A B
assume AsU: "P ⊢ A ≤ B" and BnpscA: "A = B ∨ ¬ P ⊢ B ≤ A"
{ assume "P ⊢ B⌊⌉ ≤ A⌊⌉"
hence "P ⊢ B ≤ A" by (auto dest: Array_Array_widen)
with BnpscA have "A = B" by blast
hence "A⌊⌉ = B⌊⌉" by simp }
thus "A⌊⌉ = B⌊⌉ ∨ ¬ P ⊢ B⌊⌉ ≤ A⌊⌉" by blast
qed
lemma widen_asym: "⟦ wf_prog wf_md P; P ⊢ C ≤ D; C ≠ D ⟧ ⟹ ¬ (P ⊢ D ≤ C)"
proof -
assume wfP: "wf_prog wf_md P" and CsD: "P ⊢ C ≤ D" and CneqD: "C ≠ D"
from wfP CsD have "C = D ∨ ¬ (P ⊢ D ≤ C)" by (rule widen_asym_1)
with CneqD show ?thesis by simp
qed
lemma widen_antisym:
"⟦ wf_prog m P; P ⊢ T ≤ U; P ⊢ U ≤ T ⟧ ⟹ T = U"
by(auto dest: widen_asym)
lemma widen_C_Object: "⟦ wf_prog wf_md P; is_class P C ⟧ ⟹ P ⊢ Class C ≤ Class Object"
by(simp add: subcls_C_Object)
lemma is_refType_widen_Object:
assumes wfP: "wf_prog wfmc P"
shows "⟦ is_type P A; is_refT A ⟧ ⟹ P ⊢ A ≤ Class Object"
by(induct A)(auto elim: refTE intro: subcls_C_Object[OF _ wfP] widen_array_object)
lemma is_lub_unique:
assumes wf: "wf_prog wf_md P"
shows "⟦ P ⊢ lub(U, V) = T; P ⊢ lub(U, V) = T' ⟧ ⟹ T = T'"
by(auto elim!: is_lub.cases intro: widen_antisym[OF wf])
subsection‹Well-formedness and method lookup›
lemma sees_wf_mdecl:
"⟦ wf_prog wf_md P; P ⊢ C sees M:Ts→T = m in D ⟧ ⟹ wf_mdecl wf_md P D (M,Ts,T,m)"
apply(drule visible_method_exists)
apply(clarify)
apply(drule class_wf, assumption)
apply(drule map_of_SomeD)
apply(auto simp add: wf_cdecl_def)
done
lemma sees_method_mono [rule_format (no_asm)]:
"⟦ P ⊢ C' ≼⇧* C; wf_prog wf_md P ⟧ ⟹
∀D Ts T m. P ⊢ C sees M:Ts→T = m in D ⟶
(∃D' Ts' T' m'. P ⊢ C' sees M:Ts'→T' = m' in D' ∧ P ⊢ Ts [≤] Ts' ∧ P ⊢ T' ≤ T)"
apply( drule rtranclpD)
apply( erule disjE)
apply( fastforce intro: widen_refl widens_refl)
apply( erule conjE)
apply( erule tranclp_trans_induct)
prefer 2
apply( clarify)
apply( drule spec, drule spec, drule spec, drule spec, erule (1) impE)
apply clarify
apply( fast elim: widen_trans widens_trans)
apply( clarify)
apply( drule subcls1D)
apply( clarify)
apply(clarsimp simp:Method_def)
apply(frule (2) sees_methods_rec)
apply(rule refl)
apply(case_tac "map_of ms M")
apply(rule_tac x = D in exI)
apply(rule_tac x = Ts in exI)
apply(rule_tac x = T in exI)
apply(clarsimp simp add: widens_refl)
apply(rule_tac x = m in exI)
apply(fastforce simp add:map_add_def split:option.split)
apply clarsimp
apply(rename_tac Ts' T' m')
apply( drule (1) class_wf)
apply( unfold wf_cdecl_def Method_def)
apply( frule map_of_SomeD)
apply(clarsimp)
apply(drule (1) bspec)+
apply clarsimp
apply(erule_tac x=D in allE)
apply(erule_tac x=Ts in allE)
apply(rotate_tac -1)
apply(erule_tac x=T in allE)
apply(fastforce simp:map_add_def Method_def split:option.split)
done
lemma sees_method_mono2:
"⟦ P ⊢ C' ≼⇧* C; wf_prog wf_md P;
P ⊢ C sees M:Ts→T = m in D; P ⊢ C' sees M:Ts'→T' = m' in D' ⟧
⟹ P ⊢ Ts [≤] Ts' ∧ P ⊢ T' ≤ T"
by(blast dest:sees_method_mono sees_method_fun)
lemma mdecls_visible:
assumes wf: "wf_prog wf_md P" and "class": "is_class P C"
shows "⋀D fs ms. class P C = Some(D,fs,ms)
⟹ ∃Mm. P ⊢ C sees_methods Mm ∧ (∀(M,Ts,T,m) ∈ set ms. Mm M = Some((Ts,T,m),C))"
using wf "class"
proof (induct rule:subcls1_induct)
case Object
with wf have "distinct_fst ms"
by(auto dest: class_wf simp add: wf_cdecl_def)
with Object show ?case by(fastforce intro!: sees_methods_Object map_of_SomeI)
next
case Subcls
with wf have "distinct_fst ms"
by(auto dest: class_wf simp add: wf_cdecl_def)
with Subcls show ?case
by(fastforce elim:sees_methods_rec dest:subcls1D map_of_SomeI
simp:is_class_def)
qed
lemma mdecl_visible:
assumes wf: "wf_prog wf_md P" and C: "class P C = ⌊(S,fs,ms)⌋" and m: "(M,Ts,T,m) ∈ set ms"
shows "P ⊢ C sees M:Ts→T = m in C"
proof -
from C have "is_class P C" by(auto simp:is_class_def)
with assms show ?thesis
by(bestsimp simp:Method_def dest:mdecls_visible)
qed
lemma sees_wf_native:
"⟦ wf_prog wf_md P; P ⊢ C sees M:Ts→T=Native in D ⟧ ⟹ D∙M(Ts) :: T"
apply(drule (1) sees_wf_mdecl)
apply(simp add: wf_mdecl_def)
done
lemma Call_lemma:
"⟦ P ⊢ C sees M:Ts→T = m in D; P ⊢ C' ≼⇧* C; wf_prog wf_md P ⟧
⟹ ∃D' Ts' T' m'.
P ⊢ C' sees M:Ts'→T' = m' in D' ∧ P ⊢ Ts [≤] Ts' ∧ P ⊢ T' ≤ T ∧ P ⊢ C' ≼⇧* D'
∧ is_type P T' ∧ (∀T∈set Ts'. is_type P T) ∧ (m' ≠ Native ⟶ wf_md P D' (M,Ts',T',the m'))"
apply(frule (2) sees_method_mono)
apply(fastforce intro:sees_method_decl_above dest:sees_wf_mdecl
simp: wf_mdecl_def)
done
lemma sub_Thread_sees_run:
assumes wf: "wf_prog wf_md P"
and PCThread: "P ⊢ C ≼⇧* Thread"
shows "∃D mthd. P ⊢ C sees run: []→Void = ⌊mthd⌋ in D"
proof -
from class_Thread[OF wf] obtain T' fsT MsT
where classT: "class P Thread = ⌊(T', fsT, MsT)⌋" by blast
hence wfcThread: "wf_cdecl wf_md P (Thread, T', fsT, MsT)" using wf by(rule class_wf)
then obtain mrunT where runThread: "(run, [], Void, mrunT) ∈ set MsT"
by(auto simp add: wf_cdecl_def)
moreover have "∃MmT. P ⊢ Thread sees_methods MmT ∧
(∀(M,Ts,T,m) ∈ set MsT. MmT M = Some((Ts,T,m),Thread))"
by(rule mdecls_visible[OF wf is_class_Thread[OF wf] classT])
then obtain MmT where ThreadMmT: "P ⊢ Thread sees_methods MmT"
and MmT: "∀(M,Ts,T,m) ∈ set MsT. MmT M = Some((Ts,T,m),Thread)"
by blast
ultimately obtain mthd
where "MmT run = ⌊(([], Void, mthd), Thread)⌋"
by(fastforce)
with ThreadMmT have Tseesrun: "P ⊢ Thread sees run: []→Void = mthd in Thread"
by(auto simp add: Method_def)
from sees_method_mono[OF PCThread wf Tseesrun]
obtain D' m' where "P ⊢ C sees run: []→Void = m' in D'" by auto
moreover have "m' ≠ None"
proof
assume "m' = None"
with wf ‹P ⊢ C sees run: []→Void = m' in D'› have "D'∙run([]) :: Void"
by(auto intro: sees_wf_native)
thus False by cases auto
qed
ultimately show ?thesis by auto
qed
lemma wf_prog_lift:
assumes wf: "wf_prog (λP C bd. A P C bd) P"
and rule:
"⋀wf_md C M Ts C T m.
⟦ wf_prog wf_md P; P ⊢ C sees M:Ts→T = ⌊m⌋ in C; is_class P C; set Ts ⊆ types P; A P C (M,Ts,T,m) ⟧
⟹ B P C (M,Ts,T,m)"
shows "wf_prog (λP C bd. B P C bd) P"
proof(cases P)
case (Program P')
thus ?thesis using wf
apply(clarsimp simp add: wf_prog_def wf_cdecl_def)
apply(drule (1) bspec)
apply(rename_tac C D fs ms)
apply(subgoal_tac "is_class P C")
prefer 2
apply(simp add: is_class_def)
apply(drule weak_map_of_SomeI)
apply(simp add: Program)
apply(clarsimp simp add: Program wf_mdecl_def split del: option.split)
apply(drule (1) bspec)
apply clarsimp
apply(rule conjI)
apply clarsimp
apply clarsimp
apply(frule (1) map_of_SomeI)
apply(rule rule[OF wf, unfolded Program])
apply(clarsimp simp add: is_class_def)
apply(rule mdecl_visible[OF wf[unfolded Program]])
apply(fastforce intro: is_type_pTs [OF wf, unfolded Program])+
done
qed
subsection‹Well-formedness and field lookup›
lemma wf_Fields_Ex:
"⟦ wf_prog wf_md P; is_class P C ⟧ ⟹ ∃FDTs. P ⊢ C has_fields FDTs"
apply(frule class_Object)
apply(erule (1) subcls1_induct)
apply(blast intro:has_fields_Object)
apply(blast intro:has_fields_rec dest:subcls1D)
done
lemma has_fields_types:
"⟦ P ⊢ C has_fields FDTs; (FD, T, fm) ∈ set FDTs; wf_prog wf_md P ⟧ ⟹ is_type P T"
apply(induct rule:Fields.induct)
apply(fastforce dest!: class_wf simp: wf_cdecl_def wf_fdecl_def)
apply(fastforce dest!: class_wf simp: wf_cdecl_def wf_fdecl_def)
done
lemma sees_field_is_type:
"⟦ P ⊢ C sees F:T (fm) in D; wf_prog wf_md P ⟧ ⟹ is_type P T"
by(fastforce simp: sees_field_def
elim: has_fields_types map_of_SomeD[OF map_of_remap_SomeD])
lemma wf_has_field_mono2:
assumes wf: "wf_prog wf_md P"
and has: "P ⊢ C has F:T (fm) in E"
shows "⟦ P ⊢ C ≼⇧* D; P ⊢ D ≼⇧* E ⟧ ⟹ P ⊢ D has F:T (fm) in E"
proof(induct rule: rtranclp_induct)
case base show ?case using has .
next
case (step D D')
note DsubD' = ‹P ⊢ D ≺⇧1 D'›
from DsubD' obtain rest where classD: "class P D = ⌊(D', rest)⌋"
and DObj: "D ≠ Object" by(auto elim!: subcls1.cases)
from DsubD' ‹P ⊢ D' ≼⇧* E› have DsubE: "P ⊢ D ≼⇧* E" and DsubE2: "(subcls1 P)^++ D E"
by(rule converse_rtranclp_into_rtranclp rtranclp_into_tranclp2)+
from wf DsubE2 have DnE: "D ≠ E" by(rule subcls_irrefl)
from DsubE have hasD: "P ⊢ D has F:T (fm) in E" by(rule ‹P ⊢ D ≼⇧* E ⟹ P ⊢ D has F:T (fm) in E›)
then obtain FDTs where hasf: "P ⊢ D has_fields FDTs" and FE: "map_of FDTs (F, E) = ⌊(T, fm)⌋"
unfolding has_field_def by blast
from hasf show ?case
proof cases
case has_fields_Object with DObj show ?thesis by simp
next
case (has_fields_rec DD' fs ms FDTs')
with classD have [simp]: "DD' = D'" "rest = (fs, ms)"
and hasf': "P ⊢ D' has_fields FDTs'"
and FDTs: "FDTs = map (λ(F, Tm). ((F, D), Tm)) fs @ FDTs'" by auto
from FDTs FE DnE hasf' show ?thesis by(auto dest: map_of_SomeD simp add: has_field_def)
qed
qed
lemma wf_has_field_idemp:
"⟦ wf_prog wf_md P; P ⊢ C has F:T (fm) in D ⟧ ⟹ P ⊢ D has F:T (fm) in D"
apply(frule has_field_decl_above)
apply(erule (2) wf_has_field_mono2)
apply(rule rtranclp.rtrancl_refl)
done
lemma map_of_remap_conv:
"⟦ distinct_fst fs; map_of (map (λ(F, y). ((F, D), y)) fs) (F, D) = ⌊T⌋ ⟧
⟹ map_of (map (λ((F, D), T). (F, D, T)) (map (λ(F, y). ((F, D), y)) fs)) F = ⌊(D, T)⌋"
apply(induct fs)
apply auto
done
lemma has_field_idemp_sees_field:
assumes wf: "wf_prog wf_md P"
and has: "P ⊢ D has F:T (fm) in D"
shows "P ⊢ D sees F:T (fm) in D"
proof -
from has obtain FDTs where hasf: "P ⊢ D has_fields FDTs"
and FD: "map_of FDTs (F, D) = ⌊(T, fm)⌋" unfolding has_field_def by blast
from hasf have "map_of (map (λ((F, D), T). (F, D, T)) FDTs) F = ⌊(D, T, fm)⌋"
proof cases
case (has_fields_Object D' fs ms)
from ‹class P Object = ⌊(D', fs, ms)⌋› wf
have "wf_cdecl wf_md P (Object, D', fs, ms)" by(rule class_wf)
hence "distinct_fst fs" by(simp add: wf_cdecl_def)
with FD has_fields_Object show ?thesis by(auto intro: map_of_remap_conv simp del: map_map)
next
case (has_fields_rec D' fs ms FDTs')
hence [simp]: "FDTs = map (λ(F, Tm). ((F, D), Tm)) fs @ FDTs'"
and classD: "class P D = ⌊(D', fs, ms)⌋" and DnObj: "D ≠ Object"
and hasf': "P ⊢ D' has_fields FDTs'" by auto
from ‹class P D = ⌊(D', fs, ms)⌋› wf
have "wf_cdecl wf_md P (D, D', fs, ms)" by(rule class_wf)
hence "distinct_fst fs" by(simp add: wf_cdecl_def)
moreover have "map_of FDTs' (F, D) = None"
proof(rule ccontr)
assume "map_of FDTs' (F, D) ≠ None"
then obtain T' fm' where "map_of FDTs' (F, D) = ⌊(T', fm')⌋" by(auto)
with hasf' have "P ⊢ D' ≼⇧* D" by(auto dest!: map_of_SomeD intro: has_fields_decl_above)
with classD DnObj have "(subcls1 P)^++ D D"
by(auto intro: subcls1.intros rtranclp_into_tranclp2)
with wf show False by(auto dest: subcls_irrefl)
qed
ultimately show ?thesis using FD hasf'
by(auto simp add: map_add_Some_iff intro: map_of_remap_conv simp del: map_map)
qed
with hasf show ?thesis unfolding sees_field_def by blast
qed
lemma has_fields_distinct:
assumes wf: "wf_prog wf_md P"
and "P ⊢ C has_fields FDTs"
shows "distinct (map fst FDTs)"
using ‹P ⊢ C has_fields FDTs›
proof(induct)
case (has_fields_Object D fs ms FDTs)
have eq: "map (fst ∘ (λ(F, y). ((F, Object), y))) fs = map ((λF. (F, Object)) ∘ fst) fs" by(auto)
from ‹class P Object = ⌊(D, fs, ms)⌋› wf
have "wf_cdecl wf_md P (Object, D, fs, ms)" by(rule class_wf)
hence "distinct (map fst fs)" by(simp add: wf_cdecl_def distinct_fst_def)
hence "distinct (map (fst ∘ (λ(F, y). ((F, Object), y))) fs)"
unfolding eq distinct_map by(auto intro: comp_inj_on inj_onI)
thus ?case using ‹FDTs = map (λ(F, T). ((F, Object), T)) fs› by(simp)
next
case (has_fields_rec C D fs ms FDTs FDTs')
have eq: "map (fst ∘ (λ(F, y). ((F, C), y))) fs = map ((λF. (F, C)) ∘ fst) fs" by(auto)
from ‹class P C = ⌊(D, fs, ms)⌋› wf
have "wf_cdecl wf_md P (C, D, fs, ms)" by(rule class_wf)
hence "distinct (map fst fs)" by(simp add: wf_cdecl_def distinct_fst_def)
hence "distinct (map (fst ∘ (λ(F, y). ((F, C), y))) fs)"
unfolding eq distinct_map by(auto intro: comp_inj_on inj_onI)
moreover from ‹class P C = ⌊(D, fs, ms)⌋› ‹C ≠ Object›
have "P ⊢ C ≺⇧1 D" by(rule subcls1.intros)
with ‹P ⊢ D has_fields FDTs›
have "(fst ∘ (λ(F, y). ((F, C), y))) ` set fs ∩ fst ` set FDTs = {}"
by(auto dest: subcls_notin_has_fields)
ultimately show ?case using ‹FDTs' = map (λ(F, T). ((F, C), T)) fs @ FDTs› ‹distinct (map fst FDTs)› by simp
qed
subsection ‹Code generation›
code_pred
(modes: i ⇒ i ⇒ i ⇒ bool)
[inductify]
wf_overriding
.
text ‹
Separate subclass acycilicity from class declaration check.
Otherwise, cyclic class hierarchies might lead to non-termination
as @{term "Methods"} recurses over the class hierarchy.
›
definition acyclic_class_hierarchy :: "'m prog ⇒ bool"
where
"acyclic_class_hierarchy P ⟷
(∀(C, D, fs, ml) ∈ set (classes P). C ≠ Object ⟶ ¬ P ⊢ D ≼⇧* C)"
definition wf_cdecl' :: "'m wf_mdecl_test ⇒ 'm prog ⇒ 'm cdecl ⇒ bool"
where
"wf_cdecl' wf_md P = (λ(C,(D,fs,ms)).
(∀f∈set fs. wf_fdecl P f) ∧ distinct_fst fs ∧
(∀m∈set ms. wf_mdecl wf_md P C m) ∧
distinct_fst ms ∧
(C ≠ Object ⟶ is_class P D ∧ (∀m∈set ms. wf_overriding P D m)) ∧
(C = Thread ⟶ (∃m. (run, [], Void, m) ∈ set ms)))"
lemma acyclic_class_hierarchy_code [code]:
"acyclic_class_hierarchy P ⟷ (∀(C, D, fs, ml) ∈ set (classes P). C ≠ Object ⟶ ¬ subcls' P D C)"
by(simp add: acyclic_class_hierarchy_def subcls'_def)
lemma wf_cdecl'_code [code]:
"wf_cdecl' wf_md P = (λ(C,(D,fs,ms)).
(∀f∈set fs. wf_fdecl P f) ∧ distinct_fst fs ∧
(∀m∈set ms. wf_mdecl wf_md P C m) ∧
distinct_fst ms ∧
(C ≠ Object ⟶ is_class P D ∧ (∀m∈set ms. wf_overriding P D m)) ∧
(C = Thread ⟶ ((run, [], Void) ∈ set (map (λ(M, Ts, T, b). (M, Ts, T)) ms))))"
by(auto simp add: wf_cdecl'_def intro!: ext intro: rev_image_eqI)
declare set_append [symmetric, code_unfold]
lemma wf_prog_code [code]:
"wf_prog wf_md P ⟷
acyclic_class_hierarchy P ∧
wf_syscls P ∧ distinct_fst (classes P) ∧
(∀c ∈ set (classes P). wf_cdecl' wf_md P c)"
unfolding wf_prog_def wf_cdecl_def wf_cdecl'_def acyclic_class_hierarchy_def split_def
by blast
end
Theory ExternalCallWF
section ‹Properties of external calls in well-formed programs›
theory ExternalCallWF
imports
WellForm
"../Framework/FWSemantics"
begin
lemma external_WT_defs_is_type:
assumes "wf_prog wf_md P" and "C∙M(Ts) :: T"
shows "is_class P C" and "is_type P T" "set Ts ⊆ types P"
using assms by(auto elim: external_WT_defs.cases)
context heap_base begin
lemma WT_red_external_aggr_imp_red_external:
"⟦ wf_prog wf_md P; (ta, va, h') ∈ red_external_aggr P t a M vs h; P,h ⊢ a∙M(vs) : U; P,h ⊢ t √t ⟧
⟹ P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩"
apply(drule tconfD)
apply(erule external_WT'.cases)
apply(clarsimp)
apply(drule (1) sees_wf_native)
apply(erule external_WT_defs.cases)
apply(case_tac [!] hT)
apply(auto 4 4 simp add: red_external_aggr_def widen_Class intro: red_external.intros heap_base.red_external.intros[where addr2thread_id=addr2thread_id and thread_id2addr=thread_id2addr and spurious_wakeups=True and empty_heap=empty_heap and allocate=allocate and typeof_addr=typeof_addr and heap_read=heap_read and heap_write=heap_write] heap_base.red_external.intros[where addr2thread_id=addr2thread_id and thread_id2addr=thread_id2addr and spurious_wakeups=False and empty_heap=empty_heap and allocate=allocate and typeof_addr=typeof_addr and heap_read=heap_read and heap_write=heap_write] split: if_split_asm dest: sees_method_decl_above)
done
lemma WT_red_external_list_conv:
"⟦ wf_prog wf_md P; P,h ⊢ a∙M(vs) : U; P,h ⊢ t √t ⟧
⟹ P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩ ⟷ (ta, va, h') ∈ red_external_aggr P t a M vs h"
by(blast intro: WT_red_external_aggr_imp_red_external red_external_imp_red_external_aggr)
lemma red_external_new_thread_sees:
"⟦ wf_prog wf_md P; P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩; NewThread t' (C, M', a') h'' ∈ set ⦃ta⦄⇘t⇙ ⟧
⟹ typeof_addr h' a' = ⌊Class_type C⌋ ∧ (∃T meth D. P ⊢ C sees M':[]→T = ⌊meth⌋ in D)"
by(fastforce elim!: red_external.cases simp add: widen_Class ta_upd_simps dest: sub_Thread_sees_run)
end
subsection ‹Preservation of heap conformance›
context heap_conf_read begin
lemma hconf_heap_copy_loc_mono:
assumes "heap_copy_loc a a' al h obs h'"
and "hconf h"
and "P,h ⊢ a@al : T" "P,h ⊢ a'@al : T"
shows "hconf h'"
proof -
from ‹heap_copy_loc a a' al h obs h'› obtain v
where read: "heap_read h a al v"
and "write": "heap_write h a' al v h'" by cases auto
from read ‹P,h ⊢ a@al : T› ‹hconf h› have "P,h ⊢ v :≤ T"
by(rule heap_read_conf)
with "write" ‹hconf h› ‹P,h ⊢ a'@al : T› show ?thesis
by(rule hconf_heap_write_mono)
qed
lemma hconf_heap_copies_mono:
assumes "heap_copies a a' als h obs h'"
and "hconf h"
and "list_all2 (λal T. P,h ⊢ a@al : T) als Ts"
and "list_all2 (λal T. P,h ⊢ a'@al : T) als Ts"
shows "hconf h'"
using assms
proof(induct arbitrary: Ts)
case Nil thus ?case by simp
next
case (Cons al h ob h' als obs h'')
note step = ‹heap_copy_loc a a' al h ob h'›
from ‹list_all2 (λal T. P,h ⊢ a@al : T) (al # als) Ts›
obtain T Ts' where [simp]: "Ts = T # Ts'"
and "P,h ⊢ a@al : T" "list_all2 (λal T. P,h ⊢ a@al : T) als Ts'"
by(auto simp add: list_all2_Cons1)
from ‹list_all2 (λal T. P,h ⊢ a'@al : T) (al # als) Ts›
have "P,h ⊢ a'@al : T" "list_all2 (λal T. P,h ⊢ a'@al : T) als Ts'" by simp_all
from step ‹hconf h› ‹P,h ⊢ a@al : T› ‹P,h ⊢ a'@al : T›
have "hconf h'" by(rule hconf_heap_copy_loc_mono)
moreover from step have "h ⊴ h'" by(rule hext_heap_copy_loc)
from ‹list_all2 (λal T. P,h ⊢ a@al : T) als Ts'›
have "list_all2 (λal T. P,h' ⊢ a@al : T) als Ts'"
by(rule list_all2_mono)(rule addr_loc_type_hext_mono[OF _ ‹h ⊴ h'›])
moreover from ‹list_all2 (λal T. P,h ⊢ a'@al : T) als Ts'›
have "list_all2 (λal T. P,h' ⊢ a'@al : T) als Ts'"
by(rule list_all2_mono)(rule addr_loc_type_hext_mono[OF _ ‹h ⊴ h'›])
ultimately show ?case by(rule Cons)
qed
lemma hconf_heap_clone_mono:
assumes "heap_clone P h a h' res"
and "hconf h"
shows "hconf h'"
using ‹heap_clone P h a h' res›
proof cases
case CloneFail thus ?thesis using ‹hconf h›
by(fastforce intro: hconf_heap_ops_mono dest: typeof_addr_is_type)
next
case (ObjClone C h'' a' FDTs obs)
note FDTs = ‹P ⊢ C has_fields FDTs›
let ?als = "map (λ((F, D), Tfm). CField D F) FDTs"
let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs"
note ‹heap_copies a a' ?als h'' obs h'›
moreover from ‹typeof_addr h a = ⌊Class_type C⌋› ‹hconf h› have "is_class P C"
by(auto dest: typeof_addr_is_type)
from ‹(h'', a') ∈ allocate h (Class_type C)› have "h ⊴ h''" "hconf h''"
by(rule hext_heap_ops hconf_allocate_mono)+(simp_all add: ‹hconf h› ‹is_class P C›)
note ‹hconf h''›
moreover
from ‹typeof_addr h a = ⌊Class_type C⌋› FDTs
have "list_all2 (λal T. P,h ⊢ a@al : T) ?als ?Ts"
unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
by(fastforce intro: addr_loc_type.intros simp add: has_field_def dest: weak_map_of_SomeI)
hence "list_all2 (λal T. P,h'' ⊢ a@al : T) ?als ?Ts"
by(rule list_all2_mono)(rule addr_loc_type_hext_mono[OF _ ‹h ⊴ h''›])
moreover from ‹(h'', a') ∈ allocate h (Class_type C)› ‹is_class P C›
have "typeof_addr h'' a' = ⌊Class_type C⌋" by(auto dest: allocate_SomeD)
with FDTs have "list_all2 (λal T. P,h'' ⊢ a'@al : T) ?als ?Ts"
unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
by(fastforce intro: addr_loc_type.intros simp add: has_field_def dest: weak_map_of_SomeI)
ultimately have "hconf h'" by(rule hconf_heap_copies_mono)
thus ?thesis using ObjClone by simp
next
case (ArrClone T n h'' a' FDTs obs)
let ?als = "map (λ((F, D), Tfm). CField D F) FDTs @ map ACell [0..<n]"
let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs @ replicate n T"
note ‹heap_copies a a' ?als h'' obs h'›
moreover from ‹typeof_addr h a = ⌊Array_type T n⌋› ‹hconf h› have "is_type P (T⌊⌉)"
by(auto dest: typeof_addr_is_type)
from ‹(h'', a') ∈ allocate h (Array_type T n)› have "h ⊴ h''" "hconf h''"
by(rule hext_heap_ops hconf_allocate_mono)+(simp_all add: ‹hconf h› ‹is_type P (T⌊⌉)›[simplified])
note ‹hconf h''›
moreover from ‹h ⊴ h''› ‹typeof_addr h a = ⌊Array_type T n⌋›
have type'a: "typeof_addr h'' a = ⌊Array_type T n⌋" by(auto intro: hext_arrD)
note FDTs = ‹P ⊢ Object has_fields FDTs›
from type'a FDTs have "list_all2 (λal T. P,h'' ⊢ a@al : T) ?als ?Ts"
by(fastforce intro: list_all2_all_nthI addr_loc_type.intros simp add: has_field_def distinct_fst_def list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv dest: weak_map_of_SomeI)
moreover from ‹(h'', a') ∈ allocate h (Array_type T n)› ‹is_type P (T⌊⌉)›
have "typeof_addr h'' a' = ⌊Array_type T n⌋" by(auto dest: allocate_SomeD)
hence "list_all2 (λal T. P,h'' ⊢ a'@al : T) ?als ?Ts" using FDTs
by(fastforce intro: list_all2_all_nthI addr_loc_type.intros simp add: has_field_def distinct_fst_def list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv dest: weak_map_of_SomeI)
ultimately have "hconf h'" by(rule hconf_heap_copies_mono)
thus ?thesis using ArrClone by simp
qed
theorem external_call_hconf:
assumes major: "P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩"
and minor: "P,h ⊢ a∙M(vs) : U" "hconf h"
shows "hconf h'"
using major minor
by cases(fastforce intro: hconf_heap_clone_mono)+
end
context heap_base begin
primrec conf_extRet :: "'m prog ⇒ 'heap ⇒ 'addr extCallRet ⇒ ty ⇒ bool" where
"conf_extRet P h (RetVal v) T = (P,h ⊢ v :≤ T)"
| "conf_extRet P h (RetExc a) T = (P,h ⊢ Addr a :≤ Class Throwable)"
| "conf_extRet P h RetStaySame T = True"
end
context heap_conf begin
lemma red_external_conf_extRet:
assumes wf: "wf_prog wf_md P"
shows "⟦P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩; P,h ⊢ a∙M(vs) : U; hconf h; preallocated h; P,h ⊢ t √t ⟧
⟹ conf_extRet P h' va U"
using wf apply -
apply(frule red_external_hext)
apply(drule (1) preallocated_hext)
apply(auto elim!: red_external.cases external_WT'.cases external_WT_defs_cases dest!: sees_wf_native[OF wf])
apply(auto simp add: conf_def tconf_def intro: xcpt_subcls_Throwable dest!: hext_heap_write)
apply(case_tac hT)
apply(auto 4 4 dest!: typeof_addr_heap_clone dest: typeof_addr_is_type intro: widen_array_object subcls_C_Object)
done
end
subsection ‹Progress theorems for external calls›
context heap_progress begin
lemma heap_copy_loc_progress:
assumes hconf: "hconf h"
and alconfa: "P,h ⊢ a@al : T"
and alconfa': "P,h ⊢ a'@al : T"
shows "∃v h'. heap_copy_loc a a' al h ([ReadMem a al v, WriteMem a' al v]) h' ∧ P,h ⊢ v :≤ T ∧ hconf h'"
proof -
from heap_read_total[OF hconf alconfa]
obtain v where "heap_read h a al v" "P,h ⊢ v :≤ T" by blast
moreover from heap_write_total[OF hconf alconfa' ‹P,h ⊢ v :≤ T›] obtain h' where "heap_write h a' al v h'" ..
moreover hence "hconf h'" using hconf alconfa' ‹P,h ⊢ v :≤ T› by(rule hconf_heap_write_mono)
ultimately show ?thesis by(blast intro: heap_copy_loc.intros)
qed
lemma heap_copies_progress:
assumes "hconf h"
and "list_all2 (λal T. P,h ⊢ a@al : T) als Ts"
and "list_all2 (λal T. P,h ⊢ a'@al : T) als Ts"
shows "∃vs h'. heap_copies a a' als h (concat (map (λ(al, v). [ReadMem a al v, WriteMem a' al v]) (zip als vs))) h' ∧ hconf h'"
using assms
proof(induct als arbitrary: h Ts)
case Nil thus ?case by(auto intro: heap_copies.Nil)
next
case (Cons al als)
from ‹list_all2 (λal T. P,h ⊢ a@al : T) (al # als) Ts›
obtain T' Ts' where [simp]: "Ts = T' # Ts'"
and "P,h ⊢ a@al : T'" "list_all2 (λal T. P,h ⊢ a@al : T) als Ts'"
by(auto simp add: list_all2_Cons1)
from ‹list_all2 (λal T. P,h ⊢ a'@al : T) (al # als) Ts›
have "P,h ⊢ a'@al : T'" and "list_all2 (λal T. P,h ⊢ a'@al : T) als Ts'" by simp_all
from ‹hconf h› ‹P,h ⊢ a@al : T'› ‹P,h ⊢ a'@al : T'›
obtain v h' where "heap_copy_loc a a' al h [ReadMem a al v, WriteMem a' al v] h'"
and "hconf h'" by(fastforce dest: heap_copy_loc_progress)
moreover hence "h ⊴ h'" by-(rule hext_heap_copy_loc)
{
note ‹hconf h'›
moreover from ‹list_all2 (λal T. P,h ⊢ a@al : T) als Ts'›
have "list_all2 (λal T. P,h' ⊢ a@al : T) als Ts'"
by(rule list_all2_mono)(rule addr_loc_type_hext_mono[OF _ ‹h ⊴ h'›])
moreover from ‹list_all2 (λal T. P,h ⊢ a'@al : T) als Ts'›
have "list_all2 (λal T. P,h' ⊢ a'@al : T) als Ts'"
by(rule list_all2_mono)(rule addr_loc_type_hext_mono[OF _ ‹h ⊴ h'›])
ultimately have "∃vs h''. heap_copies a a' als h' (concat (map (λ(al, v). [ReadMem a al v, WriteMem a' al v]) (zip als vs))) h'' ∧ hconf h''"
by(rule Cons) }
then obtain vs h''
where "heap_copies a a' als h' (concat (map (λ(al, v). [ReadMem a al v, WriteMem a' al v]) (zip als vs))) h''"
and "hconf h''" by blast
ultimately
have "heap_copies a a' (al # als) h ([ReadMem a al v, WriteMem a' al v] @ (concat (map (λ(al, v). [ReadMem a al v, WriteMem a' al v]) (zip als vs)))) h''"
by- (rule heap_copies.Cons)
also have "[ReadMem a al v, WriteMem a' al v] @ (concat (map (λ(al, v). [ReadMem a al v, WriteMem a' al v]) (zip als vs))) =
(concat (map (λ(al, v). [ReadMem a al v, WriteMem a' al v]) (zip (al # als) (v # vs))))" by simp
finally show ?case using ‹hconf h''› by blast
qed
lemma heap_clone_progress:
assumes wf: "wf_prog wf_md P"
and typea: "typeof_addr h a = ⌊hT⌋"
and hconf: "hconf h"
shows "∃h' res. heap_clone P h a h' res"
proof -
from typea hconf have "is_htype P hT" by(rule typeof_addr_is_type)
show ?thesis
proof(cases "allocate h hT = {}")
case True
with typea CloneFail[of h a hT P]
show ?thesis by auto
next
case False
then obtain h' a' where new: "(h', a') ∈ allocate h hT" by(rule not_empty_pairE)
hence "h ⊴ h'" by(rule hext_allocate)
have "hconf h'" using new hconf ‹is_htype P hT› by(rule hconf_allocate_mono)
show ?thesis
proof(cases hT)
case [simp]: (Class_type C)
from ‹is_htype P hT› have "is_class P C" by simp
from wf_Fields_Ex[OF wf this]
obtain FDTs where FDTs: "P ⊢ C has_fields FDTs" ..
let ?als = "map (λ((F, D), Tfm). CField D F) FDTs"
let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs"
from typea FDTs have "list_all2 (λal T. P,h ⊢ a@al : T) ?als ?Ts"
unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
by(fastforce intro: addr_loc_type.intros simp add: has_field_def dest: weak_map_of_SomeI)
hence "list_all2 (λal T. P,h' ⊢ a@al : T) ?als ?Ts"
by(rule list_all2_mono)(simp add: addr_loc_type_hext_mono[OF _ ‹h ⊴ h'›] split_def)
moreover from new ‹is_class P C›
have "typeof_addr h' a' = ⌊Class_type C⌋" by(auto dest: allocate_SomeD)
with FDTs have "list_all2 (λal T. P,h' ⊢ a'@al : T) ?als ?Ts"
unfolding list_all2_map1 list_all2_map2 list_all2_refl_conv
by(fastforce intro: addr_loc_type.intros map_of_SomeI simp add: has_field_def dest: weak_map_of_SomeI)
ultimately obtain obs h'' where "heap_copies a a' ?als h' obs h''" "hconf h''"
by(blast dest: heap_copies_progress[OF ‹hconf h'›])
with typea new FDTs ObjClone[of h a C h' a' P FDTs obs h'']
show ?thesis by auto
next
case [simp]: (Array_type T n)
from wf obtain FDTs where FDTs: "P ⊢ Object has_fields FDTs"
by(blast dest: wf_Fields_Ex is_class_Object)
let ?als = "map (λ((F, D), Tfm). CField D F) FDTs @ map ACell [0..<n]"
let ?Ts = "map (λ(FD, T). fst (the (map_of FDTs FD))) FDTs @ replicate n T"
from ‹h ⊴ h'› typea have type'a: "typeof_addr h' a = ⌊Array_type T n⌋"
by(auto intro: hext_arrD)
from type'a FDTs have "list_all2 (λal T. P,h' ⊢ a@al : T) ?als ?Ts"
by(fastforce intro: list_all2_all_nthI addr_loc_type.intros simp add: has_field_def list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv dest: weak_map_of_SomeI)
moreover from new ‹is_htype P hT›
have "typeof_addr h' a' = ⌊Array_type T n⌋"
by(auto dest: allocate_SomeD)
hence "list_all2 (λal T. P,h' ⊢ a'@al : T) ?als ?Ts" using FDTs
by(fastforce intro: list_all2_all_nthI addr_loc_type.intros simp add: has_field_def list_all2_append list_all2_map1 list_all2_map2 list_all2_refl_conv dest: weak_map_of_SomeI)
ultimately obtain obs h'' where "heap_copies a a' ?als h' obs h''" "hconf h''"
by(blast dest: heap_copies_progress[OF ‹hconf h'›])
with typea new FDTs ArrClone[of h a T n h' a' P FDTs obs h'']
show ?thesis by auto
qed
qed
qed
theorem external_call_progress:
assumes wf: "wf_prog wf_md P"
and wt: "P,h ⊢ a∙M(vs) : U"
and hconf: "hconf h"
shows "∃ta va h'. P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩"
proof -
note [simp del] = split_paired_Ex
from wt obtain hT Ts Ts' D
where T: "typeof_addr h a = ⌊hT⌋" and Ts: "map typeof⇘h⇙ vs = map Some Ts"
and "P ⊢ class_type_of hT sees M:Ts'→U = Native in D" and subTs: "P ⊢ Ts [≤] Ts'"
unfolding external_WT'_iff by blast
from wf ‹P ⊢ class_type_of hT sees M:Ts'→U = Native in D›
have "D∙M(Ts') :: U" by(rule sees_wf_native)
moreover from ‹P ⊢ class_type_of hT sees M:Ts'→U = Native in D›
have "P ⊢ ty_of_htype hT ≤ Class D"
by(cases hT)(auto dest: sees_method_decl_above intro: widen_trans widen_array_object)
ultimately show ?thesis using T Ts subTs
proof cases
assume [simp]: "D = Object" "M = clone" "Ts' = []" "U = Class Object"
from heap_clone_progress[OF wf T hconf] obtain h' res where "heap_clone P h a h' res" by blast
thus ?thesis using subTs Ts by(cases res)(auto intro: red_external.intros)
qed(auto simp add: widen_Class intro: red_external.intros)
qed
end
subsection ‹Lemmas for preservation of deadlocked threads›
context heap_progress begin
lemma red_external_wt_hconf_hext:
assumes wf: "wf_prog wf_md P"
and red: "P,t ⊢ ⟨a∙M(vs),h⟩ -ta→ext ⟨va,h'⟩"
and hext: "h'' ⊴ h"
and wt: "P,h'' ⊢ a∙M(vs) : U"
and tconf: "P,h'' ⊢ t √t"
and hconf: "hconf h''"
shows "∃ta' va' h'''. P,t ⊢ ⟨a∙M(vs),h''⟩ -ta'→ext ⟨va', h'''⟩ ∧
collect_locks ⦃ta⦄⇘l⇙ = collect_locks ⦃ta'⦄⇘l⇙ ∧
collect_cond_actions ⦃ta⦄⇘c⇙ = collect_cond_actions ⦃ta'⦄⇘c⇙ ∧
collect_interrupts ⦃ta⦄⇘i⇙ = collect_interrupts ⦃ta'⦄⇘i⇙"
using red wt hext
proof cases
case (RedClone obs a')
from wt obtain hT C Ts Ts' D
where T: "typeof_addr h'' a = ⌊hT⌋"
unfolding external_WT'_iff by blast
from heap_clone_progress[OF wf T hconf]
obtain h''' res where "heap_clone P h'' a h''' res" by blast
thus ?thesis using RedClone
by(cases res)(fastforce intro: red_external.intros)+
next
case RedCloneFail
from wt obtain hT Ts Ts'
where T: "typeof_addr h'' a = ⌊hT⌋"
unfolding external_WT'_iff by blast
from heap_clone_progress[OF wf T hconf]
obtain h''' res where "heap_clone P h'' a h''' res" by blast
thus ?thesis using RedCloneFail
by(cases res)(fastforce intro: red_external.intros)+
qed(fastforce simp add: ta_upd_simps elim!: external_WT'.cases intro: red_external.intros[simplified] dest: typeof_addr_hext_mono)+
lemma red_external_wf_red:
assumes wf: "wf_prog wf_md P"
and red: "P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩"
and tconf: "P,h ⊢ t √t"
and hconf: "hconf h"
and wst: "wset s t = None ∨ (M = wait ∧ (∃w. wset s t = ⌊PostWS w⌋))"
obtains ta' va' h''
where "P,t ⊢ ⟨a∙M(vs), h⟩ -ta'→ext ⟨va', h''⟩"
and "final_thread.actions_ok final s t ta' ∨ final_thread.actions_ok' s t ta' ∧ final_thread.actions_subset ta' ta"
proof(atomize_elim)
let ?a_t = "thread_id2addr t"
let ?t_a = "addr2thread_id a"
from tconf obtain C where ht: "typeof_addr h ?a_t = ⌊Class_type C⌋"
and sub: "P ⊢ C ≼⇧* Thread" by(fastforce dest: tconfD)
show "∃ta' va' h'. P,t ⊢ ⟨a∙M(vs), h⟩ -ta'→ext ⟨va', h'⟩ ∧ (final_thread.actions_ok final s t ta' ∨ final_thread.actions_ok' s t ta' ∧ final_thread.actions_subset ta' ta)"
proof(cases "final_thread.actions_ok' s t ta")
case True
have "final_thread.actions_subset ta ta" by(rule final_thread.actions_subset_refl)
with True red show ?thesis by blast
next
case False
note [simp] = final_thread.actions_ok'_iff lock_ok_las'_def final_thread.cond_action_oks'_subset_Join
final_thread.actions_subset_iff ta_upd_simps collect_cond_actions_def collect_interrupts_def
note [rule del] = subsetI
note [intro] = collect_locks'_subset_collect_locks red_external.intros[simplified]
show ?thesis
proof(cases "wset s t")
case [simp]: (Some w)
with wst obtain w' where [simp]: "w = PostWS w'" "M = wait" by auto
from red have [simp]: "vs = []" by(auto elim: red_external.cases)
show ?thesis
proof(cases w')
case [simp]: WSWokenUp
let ?ta' = "⦃WokenUp, ClearInterrupt t, ObsInterrupted t⦄"
have "final_thread.actions_ok' s t ?ta'" by(simp add: wset_actions_ok_def)
moreover have "final_thread.actions_subset ?ta' ta"
by(auto simp add: collect_locks'_def finfun_upd_apply)
moreover from RedWaitInterrupted
have "∃va h'. P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩" by auto
ultimately show ?thesis by blast
next
case [simp]: WSNotified
let ?ta' = "⦃Notified⦄"
have "final_thread.actions_ok' s t ?ta'" by(simp add: wset_actions_ok_def)
moreover have "final_thread.actions_subset ?ta' ta"
by(auto simp add: collect_locks'_def finfun_upd_apply)
moreover from RedWaitNotified
have "∃va h'. P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩" by auto
ultimately show ?thesis by blast
qed
next
case None
from red False show ?thesis
proof cases
case (RedNewThread C)
note ta = ‹ta = ⦃NewThread ?t_a (C, run, a) h, ThreadStart ?t_a⦄›
let ?ta' = "⦃ThreadExists ?t_a True⦄"
from ta False None have "final_thread.actions_ok' s t ?ta'" by(auto)
moreover from ta have "final_thread.actions_subset ?ta' ta" by(auto)
ultimately show ?thesis using RedNewThread by(fastforce)
next
case RedNewThreadFail
then obtain va' h' x where "P,t ⊢ ⟨a∙M(vs), h⟩ -⦃NewThread ?t_a x h', ThreadStart ?t_a⦄→ext ⟨va', h'⟩"
by(fastforce)
moreover from ‹ta = ⦃ThreadExists ?t_a True⦄› False None
have "final_thread.actions_ok' s t ⦃NewThread ?t_a x h', ThreadStart ?t_a⦄" by(auto)
moreover from ‹ta = ⦃ThreadExists ?t_a True⦄›
have "final_thread.actions_subset ⦃NewThread ?t_a x h', ThreadStart ?t_a⦄ ta" by(auto)
ultimately show ?thesis by blast
next
case RedJoin
let ?ta = "⦃IsInterrupted t True, ClearInterrupt t, ObsInterrupted t⦄"
from ‹ta = ⦃Join (addr2thread_id a), IsInterrupted t False, ThreadJoin (addr2thread_id a)⦄› None False
have "t ∈ interrupts s" by(auto)
hence "final_thread.actions_ok final s t ?ta"
using None by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps)
moreover obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta→ext ⟨va,h'⟩" using RedJoinInterrupt RedJoin by auto
ultimately show ?thesis by blast
next
case RedJoinInterrupt
hence False using False None by(auto)
thus ?thesis ..
next
case RedInterrupt
let ?ta = "⦃ThreadExists (addr2thread_id a) False⦄"
from RedInterrupt None False
have "free_thread_id (thr s) (addr2thread_id a)" by(auto simp add: wset_actions_ok_def)
hence "final_thread.actions_ok final s t ?ta" using None
by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps)
moreover obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta→ext ⟨va,h'⟩" using RedInterruptInexist RedInterrupt by auto
ultimately show ?thesis by blast
next
case RedInterruptInexist
let ?ta = "⦃ThreadExists (addr2thread_id a) True, WakeUp (addr2thread_id a), Interrupt (addr2thread_id a), ObsInterrupt (addr2thread_id a)⦄"
from RedInterruptInexist None False
have "¬ free_thread_id (thr s) (addr2thread_id a)" by(auto simp add: wset_actions_ok_def)
hence "final_thread.actions_ok final s t ?ta" using None
by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps wset_actions_ok_def)
moreover obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta→ext ⟨va,h'⟩" using RedInterruptInexist RedInterrupt by auto
ultimately show ?thesis by blast
next
case (RedIsInterruptedTrue C)
let ?ta' = "⦃IsInterrupted ?t_a False⦄"
from RedIsInterruptedTrue False None have "?t_a ∉ interrupts s" by(auto)
hence "final_thread.actions_ok' s t ?ta'" using None by auto
moreover from RedIsInterruptedTrue have "final_thread.actions_subset ?ta' ta" by auto
moreover from RedIsInterruptedTrue RedIsInterruptedFalse obtain va h'
where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩" by auto
ultimately show ?thesis by blast
next
case (RedIsInterruptedFalse C)
let ?ta' = "⦃IsInterrupted ?t_a True, ObsInterrupted ?t_a⦄"
from RedIsInterruptedFalse have "?t_a ∈ interrupts s"
using False None by(auto)
hence "final_thread.actions_ok final s t ?ta'"
using None by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps)
moreover obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩"
using RedIsInterruptedFalse RedIsInterruptedTrue by auto
ultimately show ?thesis by blast
next
case RedWaitInterrupt
note ta = ‹ta = ⦃Unlock→a, Lock→a, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t⦄›
from ta False None have hli: "¬ has_lock (locks s $ a) t ∨ t ∉ interrupts s"
by(fastforce simp add: lock_actions_ok'_iff finfun_upd_apply split: if_split_asm dest: may_lock_t_may_lock_unlock_lock_t dest: has_lock_may_lock)
show ?thesis
proof(cases "has_lock (locks s $ a) t")
case True
let ?ta' = "⦃Suspend a, Unlock→a, Lock→a, ReleaseAcquire→a, IsInterrupted t False, SyncUnlock a ⦄"
from True hli have "t ∉ interrupts s" by simp
with True False have "final_thread.actions_ok' s t ?ta'" using None
by(auto simp add: lock_actions_ok'_iff finfun_upd_apply wset_actions_ok_def Cons_eq_append_conv)
moreover from ta have "final_thread.actions_subset ?ta' ta"
by(auto simp add: collect_locks'_def finfun_upd_apply)
moreover from RedWait RedWaitInterrupt obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩" by auto
ultimately show ?thesis by blast
next
case False
let ?ta' = "⦃UnlockFail→a⦄"
from False have "final_thread.actions_ok' s t ?ta'" using None
by(auto simp add: lock_actions_ok'_iff finfun_upd_apply)
moreover from ta have "final_thread.actions_subset ?ta' ta"
by(auto simp add: collect_locks'_def finfun_upd_apply)
moreover from RedWaitInterrupt obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩" by(fastforce)
ultimately show ?thesis by blast
qed
next
case RedWait
note ta = ‹ta = ⦃Suspend a, Unlock→a, Lock→a, ReleaseAcquire→a, IsInterrupted t False, SyncUnlock a⦄›
from ta False None have hli: "¬ has_lock (locks s $ a) t ∨ t ∈ interrupts s"
by(auto simp add: lock_actions_ok'_iff finfun_upd_apply wset_actions_ok_def Cons_eq_append_conv split: if_split_asm dest: may_lock_t_may_lock_unlock_lock_t dest: has_lock_may_lock)
show ?thesis
proof(cases "has_lock (locks s $ a) t")
case True
let ?ta' = "⦃Unlock→a, Lock→a, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t⦄"
from True hli have "t ∈ interrupts s" by simp
with True False have "final_thread.actions_ok final s t ?ta'" using None
by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps lock_ok_las_def finfun_upd_apply has_lock_may_lock)
moreover from RedWait RedWaitInterrupt obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩" by auto
ultimately show ?thesis by blast
next
case False
let ?ta' = "⦃UnlockFail→a⦄"
from False have "final_thread.actions_ok' s t ?ta'" using None
by(auto simp add: lock_actions_ok'_iff finfun_upd_apply)
moreover from ta have "final_thread.actions_subset ?ta' ta"
by(auto simp add: collect_locks'_def finfun_upd_apply)
moreover from RedWait RedWaitFail obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩" by(fastforce)
ultimately show ?thesis by blast
qed
next
case RedWaitFail
note ta = ‹ta = ⦃UnlockFail→a⦄›
let ?ta' = "if t ∈ interrupts s
then ⦃Unlock→a, Lock→a, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t⦄
else ⦃Suspend a, Unlock→a, Lock→a, ReleaseAcquire→a, IsInterrupted t False, SyncUnlock a ⦄"
from ta False None have "has_lock (locks s $ a) t"
by(auto simp add: finfun_upd_apply split: if_split_asm)
hence "final_thread.actions_ok final s t ?ta'" using None
by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps lock_ok_las_def finfun_upd_apply has_lock_may_lock wset_actions_ok_def)
moreover from RedWaitFail RedWait RedWaitInterrupt
obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩"
by(cases "t ∈ interrupts s") (auto)
ultimately show ?thesis by blast
next
case RedWaitNotified
note ta = ‹ta = ⦃Notified⦄›
let ?ta' = "if has_lock (locks s $ a) t
then (if t ∈ interrupts s
then ⦃Unlock→a, Lock→a, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t⦄
else ⦃Suspend a, Unlock→a, Lock→a, ReleaseAcquire→a, IsInterrupted t False, SyncUnlock a ⦄)
else ⦃UnlockFail→a⦄"
have "final_thread.actions_ok final s t ?ta'" using None
by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps lock_ok_las_def finfun_upd_apply has_lock_may_lock wset_actions_ok_def)
moreover from RedWaitNotified RedWait RedWaitInterrupt RedWaitFail
have "∃va h'. P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩" by auto
ultimately show ?thesis by blast
next
case RedWaitInterrupted
note ta = ‹ta = ⦃WokenUp, ClearInterrupt t, ObsInterrupted t⦄›
let ?ta' = "if has_lock (locks s $ a) t
then (if t ∈ interrupts s
then ⦃Unlock→a, Lock→a, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t⦄
else ⦃Suspend a, Unlock→a, Lock→a, ReleaseAcquire→a, IsInterrupted t False, SyncUnlock a ⦄)
else ⦃UnlockFail→a⦄"
have "final_thread.actions_ok final s t ?ta'" using None
by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps lock_ok_las_def finfun_upd_apply has_lock_may_lock wset_actions_ok_def)
moreover from RedWaitInterrupted RedWait RedWaitInterrupt RedWaitFail
have "∃va h'. P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩" by auto
ultimately show ?thesis by blast
next
case RedWaitSpurious
note ta = ‹ta = ⦃Unlock→a, Lock→a, ReleaseAcquire→a, IsInterrupted t False, SyncUnlock a⦄›
from ta False None have hli: "¬ has_lock (locks s $ a) t ∨ t ∈ interrupts s"
by(auto simp add: lock_actions_ok'_iff finfun_upd_apply wset_actions_ok_def Cons_eq_append_conv split: if_split_asm dest: may_lock_t_may_lock_unlock_lock_t dest: has_lock_may_lock)
show ?thesis
proof(cases "has_lock (locks s $ a) t")
case True
let ?ta' = "⦃Unlock→a, Lock→a, IsInterrupted t True, ClearInterrupt t, ObsInterrupted t⦄"
from True hli have "t ∈ interrupts s" by simp
with True False have "final_thread.actions_ok final s t ?ta'" using None
by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps lock_ok_las_def finfun_upd_apply has_lock_may_lock)
moreover from RedWaitInterrupt RedWaitSpurious(1-5)
obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩" by auto
ultimately show ?thesis by blast
next
case False
let ?ta' = "⦃UnlockFail→a⦄"
from False have "final_thread.actions_ok' s t ?ta'" using None
by(auto simp add: lock_actions_ok'_iff finfun_upd_apply)
moreover from ta have "final_thread.actions_subset ?ta' ta"
by(auto simp add: collect_locks'_def finfun_upd_apply)
moreover from RedWaitSpurious(1-5) RedWaitFail
obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩" by(fastforce)
ultimately show ?thesis by blast
qed
next
case RedNotify
note ta = ‹ta = ⦃Notify a, Unlock→a, Lock→a⦄›
let ?ta' = "⦃UnlockFail→a⦄"
from ta False None have "¬ has_lock (locks s $ a) t"
by(fastforce simp add: lock_actions_ok'_iff finfun_upd_apply wset_actions_ok_def Cons_eq_append_conv split: if_split_asm dest: may_lock_t_may_lock_unlock_lock_t has_lock_may_lock)
hence "final_thread.actions_ok' s t ?ta'" using None
by(auto simp add: lock_actions_ok'_iff finfun_upd_apply)
moreover from ta have "final_thread.actions_subset ?ta' ta"
by(auto simp add: collect_locks'_def finfun_upd_apply)
moreover from RedNotify obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩" by(fastforce)
ultimately show ?thesis by blast
next
case RedNotifyFail
note ta = ‹ta = ⦃UnlockFail→a⦄›
let ?ta' = "⦃Notify a, Unlock→a, Lock→a⦄"
from ta False None have "has_lock (locks s $ a) t"
by(auto simp add: finfun_upd_apply split: if_split_asm)
hence "final_thread.actions_ok' s t ?ta'" using None
by(auto simp add: finfun_upd_apply simp add: wset_actions_ok_def intro: has_lock_may_lock)
moreover from ta have "final_thread.actions_subset ?ta' ta"
by(auto simp add: collect_locks'_def finfun_upd_apply)
moreover from RedNotifyFail obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩" by(fastforce)
ultimately show ?thesis by blast
next
case RedNotifyAll
note ta = ‹ta = ⦃NotifyAll a, Unlock→a, Lock→a⦄›
let ?ta' = "⦃UnlockFail→a⦄"
from ta False None have "¬ has_lock (locks s $ a) t"
by(auto simp add: lock_actions_ok'_iff finfun_upd_apply wset_actions_ok_def Cons_eq_append_conv split: if_split_asm dest: may_lock_t_may_lock_unlock_lock_t)
hence "final_thread.actions_ok' s t ?ta'" using None
by(auto simp add: lock_actions_ok'_iff finfun_upd_apply)
moreover from ta have "final_thread.actions_subset ?ta' ta"
by(auto simp add: collect_locks'_def finfun_upd_apply)
moreover from RedNotifyAll obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩" by(fastforce)
ultimately show ?thesis by blast
next
case RedNotifyAllFail
note ta = ‹ta = ⦃UnlockFail→a⦄›
let ?ta' = "⦃NotifyAll a, Unlock→a, Lock→a⦄"
from ta False None have "has_lock (locks s $ a) t"
by(auto simp add: finfun_upd_apply split: if_split_asm)
hence "final_thread.actions_ok' s t ?ta'" using None
by(auto simp add: finfun_upd_apply wset_actions_ok_def intro: has_lock_may_lock)
moreover from ta have "final_thread.actions_subset ?ta' ta"
by(auto simp add: collect_locks'_def finfun_upd_apply)
moreover from RedNotifyAllFail obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩" by(fastforce)
ultimately show ?thesis by blast
next
case RedInterruptedTrue
let ?ta' = "⦃IsInterrupted t False⦄"
from RedInterruptedTrue have "final_thread.actions_ok final s t ?ta'"
using None False by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps)
moreover obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩"
using RedInterruptedFalse RedInterruptedTrue by auto
ultimately show ?thesis by blast
next
case RedInterruptedFalse
let ?ta' = "⦃IsInterrupted t True, ClearInterrupt t, ObsInterrupted t⦄"
from RedInterruptedFalse have "final_thread.actions_ok final s t ?ta'"
using None False
by(auto simp add: final_thread.actions_ok_iff final_thread.cond_action_oks.simps)
moreover obtain va h' where "P,t ⊢ ⟨a∙M(vs),h⟩ -?ta'→ext ⟨va,h'⟩"
using RedInterruptedFalse RedInterruptedTrue by auto
ultimately show ?thesis by blast
qed(auto simp add: None)
qed
qed
qed
end
context heap_base begin
lemma red_external_ta_satisfiable:
fixes final
assumes "P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩"
shows "∃s. final_thread.actions_ok final s t ta"
proof -
note [simp] =
final_thread.actions_ok_iff final_thread.cond_action_oks.simps final_thread.cond_action_ok.simps
lock_ok_las_def finfun_upd_apply wset_actions_ok_def has_lock_may_lock
and [intro] =
free_thread_id.intros
and [cong] = conj_cong
from assms show ?thesis by cases(fastforce intro: exI[where x="(K$ None)(a $:= ⌊(t, 0)⌋)"] exI[where x="(K$ None)"])+
qed
lemma red_external_aggr_ta_satisfiable:
fixes final
assumes "(ta, va, h') ∈ red_external_aggr P t a M vs h"
shows "∃s. final_thread.actions_ok final s t ta"
proof -
note [simp] =
final_thread.actions_ok_iff final_thread.cond_action_oks.simps final_thread.cond_action_ok.simps
lock_ok_las_def finfun_upd_apply wset_actions_ok_def has_lock_may_lock
and [intro] =
free_thread_id.intros
and [cong] = conj_cong
from assms show ?thesis
by(fastforce simp add: red_external_aggr_def split_beta ta_upd_simps split: if_split_asm intro: exI[where x="Map.empty"] exI[where x="(K$ None)(a $:= ⌊(t, 0)⌋)"] exI[where x="K$ None"])
qed
end
subsection ‹Determinism›
context heap_base begin
lemma heap_copy_loc_deterministic:
assumes det: "deterministic_heap_ops"
and copy: "heap_copy_loc a a' al h ops h'" "heap_copy_loc a a' al h ops' h''"
shows "ops = ops' ∧ h' = h''"
using copy
by(auto elim!: heap_copy_loc.cases dest: deterministic_heap_ops_readD[OF det] deterministic_heap_ops_writeD[OF det])
lemma heap_copies_deterministic:
assumes det: "deterministic_heap_ops"
and copy: "heap_copies a a' als h ops h'" "heap_copies a a' als h ops' h''"
shows "ops = ops' ∧ h' = h''"
using copy
apply(induct arbitrary: ops' h'')
apply(fastforce elim!: heap_copies_cases)
apply(erule heap_copies_cases)
apply clarify
apply(drule (1) heap_copy_loc_deterministic[OF det])
apply clarify
apply(unfold same_append_eq)
apply blast
done
lemma heap_clone_deterministic:
assumes det: "deterministic_heap_ops"
and clone: "heap_clone P h a h' obs" "heap_clone P h a h'' obs'"
shows "h' = h'' ∧ obs = obs'"
using clone
by(auto 4 4 elim!: heap_clone.cases dest: heap_copies_deterministic[OF det] deterministic_heap_ops_allocateD[OF det] has_fields_fun)
lemma red_external_deterministic:
fixes final
assumes det: "deterministic_heap_ops"
and red: "P,t ⊢ ⟨a∙M(vs), (shr s)⟩ -ta→ext ⟨va, h'⟩" "P,t ⊢ ⟨a∙M(vs), (shr s)⟩ -ta'→ext ⟨va', h''⟩"
and aok: "final_thread.actions_ok final s t ta" "final_thread.actions_ok final s t ta'"
shows "ta = ta' ∧ va = va' ∧ h' = h''"
using red aok
apply(simp add: final_thread.actions_ok_iff lock_ok_las_def)
apply(erule red_external.cases)
apply(erule_tac [!] red_external.cases)
apply simp_all
apply(auto simp add: finfun_upd_apply wset_actions_ok_def dest: heap_clone_deterministic[OF det] split: if_split_asm)
using deterministic_heap_ops_no_spurious_wakeups[OF det]
apply simp_all
done
end
end
Theory BinOp
section ‹Binary Operators›
theory BinOp
imports
WellForm "Word_Lib.Traditional_Infix_Syntax"
begin
datatype bop =
Eq
| NotEq
| LessThan
| LessOrEqual
| GreaterThan
| GreaterOrEqual
| Add
| Subtract
| Mult
| Div
| Mod
| BinAnd
| BinOr
| BinXor
| ShiftLeft
| ShiftRightZeros
| ShiftRightSigned
subsection‹The semantics of binary operators›
type_synonym 'addr binop_ret = "'addr val + 'addr"
fun binop_LessThan :: "'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop_LessThan (Intg i1) (Intg i2) = Some (Inl (Bool (i1 <s i2)))"
| "binop_LessThan v1 v2 = None"
fun binop_LessOrEqual :: "'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop_LessOrEqual (Intg i1) (Intg i2) = Some (Inl (Bool (i1 <=s i2)))"
| "binop_LessOrEqual v1 v2 = None"
fun binop_GreaterThan :: "'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop_GreaterThan (Intg i1) (Intg i2) = Some (Inl (Bool (i2 <s i1)))"
| "binop_GreaterThan v1 v2 = None"
fun binop_GreaterOrEqual :: "'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop_GreaterOrEqual (Intg i1) (Intg i2) = Some (Inl (Bool (i2 <=s i1)))"
| "binop_GreaterOrEqual v1 v2 = None"
fun binop_Add :: "'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop_Add (Intg i1) (Intg i2) = Some (Inl (Intg (i1 + i2)))"
| "binop_Add v1 v2 = None"
fun binop_Subtract :: "'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop_Subtract (Intg i1) (Intg i2) = Some (Inl (Intg (i1 - i2)))"
| "binop_Subtract v1 v2 = None"
fun binop_Mult :: "'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop_Mult (Intg i1) (Intg i2) = Some (Inl (Intg (i1 * i2)))"
| "binop_Mult v1 v2 = None"
fun binop_BinAnd :: "'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop_BinAnd (Intg i1) (Intg i2) = Some (Inl (Intg (i1 AND i2)))"
| "binop_BinAnd (Bool b1) (Bool b2) = Some (Inl (Bool (b1 ∧ b2)))"
| "binop_BinAnd v1 v2 = None"
fun binop_BinOr :: "'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop_BinOr (Intg i1) (Intg i2) = Some (Inl (Intg (i1 OR i2)))"
| "binop_BinOr (Bool b1) (Bool b2) = Some (Inl (Bool (b1 ∨ b2)))"
| "binop_BinOr v1 v2 = None"
fun binop_BinXor :: "'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop_BinXor (Intg i1) (Intg i2) = Some (Inl (Intg (i1 XOR i2)))"
| "binop_BinXor (Bool b1) (Bool b2) = Some (Inl (Bool (b1 ≠ b2)))"
| "binop_BinXor v1 v2 = None"
fun binop_ShiftLeft :: "'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop_ShiftLeft (Intg i1) (Intg i2) = Some (Inl (Intg (i1 << unat (i2 AND 0x1f))))"
| "binop_ShiftLeft v1 v2 = None"
fun binop_ShiftRightZeros :: "'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop_ShiftRightZeros (Intg i1) (Intg i2) = Some (Inl (Intg (i1 >> unat (i2 AND 0x1f))))"
| "binop_ShiftRightZeros v1 v2 = None"
fun binop_ShiftRightSigned :: "'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop_ShiftRightSigned (Intg i1) (Intg i2) = Some (Inl (Intg (i1 >>> unat (i2 AND 0x1f))))"
| "binop_ShiftRightSigned v1 v2 = None"
text ‹
Division on @{typ "'a word"} is unsigned, but JLS specifies signed division.
›
definition word_sdiv :: "'a :: len word ⇒ 'a word ⇒ 'a word" (infixl "sdiv" 70)
where [code]:
"x sdiv y =
(let x' = sint x; y' = sint y;
negative = (x' < 0) ≠ (y' < 0);
result = abs x' div abs y'
in word_of_int (if negative then -result else result))"
definition word_smod :: "'a :: len word ⇒ 'a word ⇒ 'a word" (infixl "smod" 70)
where [code]:
"x smod y =
(let x' = sint x; y' = sint y;
negative = (x' < 0);
result = abs x' mod abs y'
in word_of_int (if negative then -result else result))"
declare word_sdiv_def [simp] word_smod_def [simp]
lemma sdiv_smod_id: "(a sdiv b) * b + (a smod b) = a"
proof -
have F5: "∀u::'a word. - (- u) = u"
by simp
have F7: "∀v u::'a word. u + v = v + u"
by (simp add: ac_simps)
have F8: "∀(w::'a word) (v::int) u::int. word_of_int u + word_of_int v * w = word_of_int (u + v * sint w)"
by simp
have "∃u. u = - sint b ∧ word_of_int (sint a mod u + - (- u * (sint a div u))) = a"
using F5 by simp
hence "word_of_int (sint a mod - sint b + - (sint b * (sint a div - sint b))) = a"
by (metis equation_minus_iff)
hence "word_of_int (sint a mod - sint b) + word_of_int (- (sint a div - sint b)) * b = a"
using F8 by (simp add: ac_simps)
hence eq: "word_of_int (- (sint a div - sint b)) * b + word_of_int (sint a mod - sint b) = a"
using F7 by simp
show ?thesis
proof(cases "sint a < 0")
case True note a = this
show ?thesis
proof(cases "sint b < 0")
case True
with a show ?thesis
by simp (metis F7 F8 eq minus_equation_iff minus_mult_minus mod_div_mult_eq)
next
case False
from eq have "word_of_int (- (- sint a div sint b)) * b + word_of_int (- (- sint a mod sint b)) = a"
by (metis div_minus_right mod_minus_right)
with a False show ?thesis by simp
qed
next
case False note a = this
show ?thesis
proof(cases "sint b < 0")
case True
with a eq show ?thesis by simp
next
case False with a show ?thesis
by (simp add: F7 F8)
qed
qed
qed
notepad begin
have " 5 sdiv ( 3 :: word32) = 1"
and " 5 smod ( 3 :: word32) = 2"
and " 5 sdiv (-3 :: word32) = -1"
and " 5 smod (-3 :: word32) = 2"
and "(-5) sdiv ( 3 :: word32) = -1"
and "(-5) smod ( 3 :: word32) = -2"
and "(-5) sdiv (-3 :: word32) = 1"
and "(-5) smod (-3 :: word32) = -2"
and "-2147483648 sdiv 1 = (-2147483648 :: word32)"
by eval+
end
context heap_base begin
fun binop_Mod :: "'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop_Mod (Intg i1) (Intg i2) =
Some (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg (i1 smod i2)))"
| "binop_Mod v1 v2 = None"
fun binop_Div :: "'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop_Div (Intg i1) (Intg i2) =
Some (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg (i1 sdiv i2)))"
| "binop_Div v1 v2 = None"
primrec binop :: "bop ⇒ 'addr val ⇒ 'addr val ⇒ 'addr binop_ret option"
where
"binop Eq v1 v2 = Some (Inl (Bool (v1 = v2)))"
| "binop NotEq v1 v2 = Some (Inl (Bool (v1 ≠ v2)))"
| "binop LessThan = binop_LessThan"
| "binop LessOrEqual = binop_LessOrEqual"
| "binop GreaterThan = binop_GreaterThan"
| "binop GreaterOrEqual = binop_GreaterOrEqual"
| "binop Add = binop_Add"
| "binop Subtract = binop_Subtract"
| "binop Mult = binop_Mult"
| "binop Mod = binop_Mod"
| "binop Div = binop_Div"
| "binop BinAnd = binop_BinAnd"
| "binop BinOr = binop_BinOr"
| "binop BinXor = binop_BinXor"
| "binop ShiftLeft = binop_ShiftLeft"
| "binop ShiftRightZeros = binop_ShiftRightZeros"
| "binop ShiftRightSigned = binop_ShiftRightSigned"
end
lemma [simp]:
"(binop_LessThan v1 v2 = Some va) ⟷
(∃i1 i2. v1 = Intg i1 ∧ v2 = Intg i2 ∧ va = Inl (Bool (i1 <s i2)))"
by(cases "(v1, v2)" rule: binop_LessThan.cases) auto
lemma [simp]:
"(binop_LessOrEqual v1 v2 = Some va) ⟷
(∃i1 i2. v1 = Intg i1 ∧ v2 = Intg i2 ∧ va = Inl (Bool (i1 <=s i2)))"
by(cases "(v1, v2)" rule: binop_LessOrEqual.cases) auto
lemma [simp]:
"(binop_GreaterThan v1 v2 = Some va) ⟷
(∃i1 i2. v1 = Intg i1 ∧ v2 = Intg i2 ∧ va = Inl (Bool (i2 <s i1)))"
by(cases "(v1, v2)" rule: binop_GreaterThan.cases) auto
lemma [simp]:
"(binop_GreaterOrEqual v1 v2 = Some va) ⟷
(∃i1 i2. v1 = Intg i1 ∧ v2 = Intg i2 ∧ va = Inl (Bool (i2 <=s i1)))"
by(cases "(v1, v2)" rule: binop_GreaterOrEqual.cases) auto
lemma [simp]:
"(binop_Add v⇩1 v⇩2 = Some va) ⟷
(∃i⇩1 i⇩2. v⇩1 = Intg i⇩1 ∧ v⇩2 = Intg i⇩2 ∧ va = Inl (Intg (i⇩1+i⇩2)))"
by(cases "(v⇩1, v⇩2)" rule: binop_Add.cases) auto
lemma [simp]:
"(binop_Subtract v1 v2 = Some va) ⟷
(∃i1 i2. v1 = Intg i1 ∧ v2 = Intg i2 ∧ va = Inl (Intg (i1 - i2)))"
by(cases "(v1, v2)" rule: binop_Subtract.cases) auto
lemma [simp]:
"(binop_Mult v1 v2 = Some va) ⟷
(∃i1 i2. v1 = Intg i1 ∧ v2 = Intg i2 ∧ va = Inl (Intg (i1 * i2)))"
by(cases "(v1, v2)" rule: binop_Mult.cases) auto
lemma [simp]:
"(binop_BinAnd v1 v2 = Some va) ⟷
(∃b1 b2. v1 = Bool b1 ∧ v2 = Bool b2 ∧ va = Inl (Bool (b1 ∧ b2))) ∨
(∃i1 i2. v1 = Intg i1 ∧ v2 = Intg i2 ∧ va = Inl (Intg (i1 AND i2)))"
by(cases "(v1, v2)" rule: binop_BinAnd.cases) auto
lemma [simp]:
"(binop_BinOr v1 v2 = Some va) ⟷
(∃b1 b2. v1 = Bool b1 ∧ v2 = Bool b2 ∧ va = Inl (Bool (b1 ∨ b2))) ∨
(∃i1 i2. v1 = Intg i1 ∧ v2 = Intg i2 ∧ va = Inl (Intg (i1 OR i2)))"
by(cases "(v1, v2)" rule: binop_BinOr.cases) auto
lemma [simp]:
"(binop_BinXor v1 v2 = Some va) ⟷
(∃b1 b2. v1 = Bool b1 ∧ v2 = Bool b2 ∧ va = Inl (Bool (b1 ≠ b2))) ∨
(∃i1 i2. v1 = Intg i1 ∧ v2 = Intg i2 ∧ va = Inl (Intg (i1 XOR i2)))"
by(cases "(v1, v2)" rule: binop_BinXor.cases) auto
lemma [simp]:
"(binop_ShiftLeft v1 v2 = Some va) ⟷
(∃i1 i2. v1 = Intg i1 ∧ v2 = Intg i2 ∧ va = Inl (Intg (i1 << unat (i2 AND 0x1f))))"
by(cases "(v1, v2)" rule: binop_ShiftLeft.cases) auto
lemma [simp]:
"(binop_ShiftRightZeros v1 v2 = Some va) ⟷
(∃i1 i2. v1 = Intg i1 ∧ v2 = Intg i2 ∧ va = Inl (Intg (i1 >> unat (i2 AND 0x1f))))"
by(cases "(v1, v2)" rule: binop_ShiftRightZeros.cases) auto
lemma [simp]:
"(binop_ShiftRightSigned v1 v2 = Some va) ⟷
(∃i1 i2. v1 = Intg i1 ∧ v2 = Intg i2 ∧ va = Inl (Intg (i1 >>> unat (i2 AND 0x1f))))"
by(cases "(v1, v2)" rule: binop_ShiftRightSigned.cases) auto
context heap_base begin
lemma [simp]:
"(binop_Mod v1 v2 = Some va) ⟷
(∃i1 i2. v1 = Intg i1 ∧ v2 = Intg i2 ∧
va = (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg(i1 smod i2))))"
by(cases "(v1, v2)" rule: binop_Mod.cases) auto
lemma [simp]:
"(binop_Div v1 v2 = Some va) ⟷
(∃i1 i2. v1 = Intg i1 ∧ v2 = Intg i2 ∧
va = (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg(i1 sdiv i2))))"
by(cases "(v1, v2)" rule: binop_Div.cases) auto
end
subsection ‹Typing for binary operators›
inductive WT_binop :: "'m prog ⇒ ty ⇒ bop ⇒ ty ⇒ ty ⇒ bool" ("_ ⊢ _«_»_ :: _" [51,0,0,0,51] 50)
where
WT_binop_Eq:
"P ⊢ T1 ≤ T2 ∨ P ⊢ T2 ≤ T1 ⟹ P ⊢ T1«Eq»T2 :: Boolean"
| WT_binop_NotEq:
"P ⊢ T1 ≤ T2 ∨ P ⊢ T2 ≤ T1 ⟹ P ⊢ T1«NotEq»T2 :: Boolean"
| WT_binop_LessThan:
"P ⊢ Integer«LessThan»Integer :: Boolean"
| WT_binop_LessOrEqual:
"P ⊢ Integer«LessOrEqual»Integer :: Boolean"
| WT_binop_GreaterThan:
"P ⊢ Integer«GreaterThan»Integer :: Boolean"
| WT_binop_GreaterOrEqual:
"P ⊢ Integer«GreaterOrEqual»Integer :: Boolean"
| WT_binop_Add:
"P ⊢ Integer«Add»Integer :: Integer"
| WT_binop_Subtract:
"P ⊢ Integer«Subtract»Integer :: Integer"
| WT_binop_Mult:
"P ⊢ Integer«Mult»Integer :: Integer"
| WT_binop_Div:
"P ⊢ Integer«Div»Integer :: Integer"
| WT_binop_Mod:
"P ⊢ Integer«Mod»Integer :: Integer"
| WT_binop_BinAnd_Bool:
"P ⊢ Boolean«BinAnd»Boolean :: Boolean"
| WT_binop_BinAnd_Int:
"P ⊢ Integer«BinAnd»Integer :: Integer"
| WT_binop_BinOr_Bool:
"P ⊢ Boolean«BinOr»Boolean :: Boolean"
| WT_binop_BinOr_Int:
"P ⊢ Integer«BinOr»Integer :: Integer"
| WT_binop_BinXor_Bool:
"P ⊢ Boolean«BinXor»Boolean :: Boolean"
| WT_binop_BinXor_Int:
"P ⊢ Integer«BinXor»Integer :: Integer"
| WT_binop_ShiftLeft:
"P ⊢ Integer«ShiftLeft»Integer :: Integer"
| WT_binop_ShiftRightZeros:
"P ⊢ Integer«ShiftRightZeros»Integer :: Integer"
| WT_binop_ShiftRightSigned:
"P ⊢ Integer«ShiftRightSigned»Integer :: Integer"
lemma WT_binopI [intro]:
"P ⊢ T1 ≤ T2 ∨ P ⊢ T2 ≤ T1 ⟹ P ⊢ T1«Eq»T2 :: Boolean"
"P ⊢ T1 ≤ T2 ∨ P ⊢ T2 ≤ T1 ⟹ P ⊢ T1«NotEq»T2 :: Boolean"
"bop = Add ∨ bop = Subtract ∨ bop = Mult ∨ bop = Mod ∨ bop = Div ∨ bop = BinAnd ∨ bop = BinOr ∨ bop = BinXor ∨
bop = ShiftLeft ∨ bop = ShiftRightZeros ∨ bop = ShiftRightSigned
⟹ P ⊢ Integer«bop»Integer :: Integer"
"bop = LessThan ∨ bop = LessOrEqual ∨ bop = GreaterThan ∨ bop = GreaterOrEqual ⟹ P ⊢ Integer«bop»Integer :: Boolean"
"bop = BinAnd ∨ bop = BinOr ∨ bop = BinXor ⟹ P ⊢ Boolean«bop»Boolean :: Boolean"
by(auto intro: WT_binop.intros)
inductive_cases [elim]:
"P ⊢ T1«Eq»T2 :: T"
"P ⊢ T1«NotEq»T2 :: T"
"P ⊢ T1«LessThan»T2 :: T"
"P ⊢ T1«LessOrEqual»T2 :: T"
"P ⊢ T1«GreaterThan»T2 :: T"
"P ⊢ T1«GreaterOrEqual»T2 :: T"
"P ⊢ T1«Add»T2 :: T"
"P ⊢ T1«Subtract»T2 :: T"
"P ⊢ T1«Mult»T2 :: T"
"P ⊢ T1«Div»T2 :: T"
"P ⊢ T1«Mod»T2 :: T"
"P ⊢ T1«BinAnd»T2 :: T"
"P ⊢ T1«BinOr»T2 :: T"
"P ⊢ T1«BinXor»T2 :: T"
"P ⊢ T1«ShiftLeft»T2 :: T"
"P ⊢ T1«ShiftRightZeros»T2 :: T"
"P ⊢ T1«ShiftRightSigned»T2 :: T"
lemma WT_binop_fun: "⟦ P ⊢ T1«bop»T2 :: T; P ⊢ T1«bop»T2 :: T' ⟧ ⟹ T = T'"
by(cases bop)(auto)
lemma WT_binop_is_type:
"⟦ P ⊢ T1«bop»T2 :: T; is_type P T1; is_type P T2 ⟧ ⟹ is_type P T"
by(cases bop) auto
inductive WTrt_binop :: "'m prog ⇒ ty ⇒ bop ⇒ ty ⇒ ty ⇒ bool" ("_ ⊢ _«_»_ : _" [51,0,0,0,51] 50)
where
WTrt_binop_Eq:
"P ⊢ T1«Eq»T2 : Boolean"
| WTrt_binop_NotEq:
"P ⊢ T1«NotEq»T2 : Boolean"
| WTrt_binop_LessThan:
"P ⊢ Integer«LessThan»Integer : Boolean"
| WTrt_binop_LessOrEqual:
"P ⊢ Integer«LessOrEqual»Integer : Boolean"
| WTrt_binop_GreaterThan:
"P ⊢ Integer«GreaterThan»Integer : Boolean"
| WTrt_binop_GreaterOrEqual:
"P ⊢ Integer«GreaterOrEqual»Integer : Boolean"
| WTrt_binop_Add:
"P ⊢ Integer«Add»Integer : Integer"
| WTrt_binop_Subtract:
"P ⊢ Integer«Subtract»Integer : Integer"
| WTrt_binop_Mult:
"P ⊢ Integer«Mult»Integer : Integer"
| WTrt_binop_Div:
"P ⊢ Integer«Div»Integer : Integer"
| WTrt_binop_Mod:
"P ⊢ Integer«Mod»Integer : Integer"
| WTrt_binop_BinAnd_Bool:
"P ⊢ Boolean«BinAnd»Boolean : Boolean"
| WTrt_binop_BinAnd_Int:
"P ⊢ Integer«BinAnd»Integer : Integer"
| WTrt_binop_BinOr_Bool:
"P ⊢ Boolean«BinOr»Boolean : Boolean"
| WTrt_binop_BinOr_Int:
"P ⊢ Integer«BinOr»Integer : Integer"
| WTrt_binop_BinXor_Bool:
"P ⊢ Boolean«BinXor»Boolean : Boolean"
| WTrt_binop_BinXor_Int:
"P ⊢ Integer«BinXor»Integer : Integer"
| WTrt_binop_ShiftLeft:
"P ⊢ Integer«ShiftLeft»Integer : Integer"
| WTrt_binop_ShiftRightZeros:
"P ⊢ Integer«ShiftRightZeros»Integer : Integer"
| WTrt_binop_ShiftRightSigned:
"P ⊢ Integer«ShiftRightSigned»Integer : Integer"
lemma WTrt_binopI [intro]:
"P ⊢ T1«Eq»T2 : Boolean"
"P ⊢ T1«NotEq»T2 : Boolean"
"bop = Add ∨ bop = Subtract ∨ bop = Mult ∨ bop = Div ∨ bop = Mod ∨ bop = BinAnd ∨ bop = BinOr ∨ bop = BinXor ∨
bop = ShiftLeft ∨ bop = ShiftRightZeros ∨ bop = ShiftRightSigned
⟹ P ⊢ Integer«bop»Integer : Integer"
"bop = LessThan ∨ bop = LessOrEqual ∨ bop = GreaterThan ∨ bop = GreaterOrEqual ⟹ P ⊢ Integer«bop»Integer : Boolean"
"bop = BinAnd ∨ bop = BinOr ∨ bop = BinXor ⟹ P ⊢ Boolean«bop»Boolean : Boolean"
by(auto intro: WTrt_binop.intros)
inductive_cases WTrt_binop_cases [elim]:
"P ⊢ T1«Eq»T2 : T"
"P ⊢ T1«NotEq»T2 : T"
"P ⊢ T1«LessThan»T2 : T"
"P ⊢ T1«LessOrEqual»T2 : T"
"P ⊢ T1«GreaterThan»T2 : T"
"P ⊢ T1«GreaterOrEqual»T2 : T"
"P ⊢ T1«Add»T2 : T"
"P ⊢ T1«Subtract»T2 : T"
"P ⊢ T1«Mult»T2 : T"
"P ⊢ T1«Div»T2 : T"
"P ⊢ T1«Mod»T2 : T"
"P ⊢ T1«BinAnd»T2 : T"
"P ⊢ T1«BinOr»T2 : T"
"P ⊢ T1«BinXor»T2 : T"
"P ⊢ T1«ShiftLeft»T2 : T"
"P ⊢ T1«ShiftRightZeros»T2 : T"
"P ⊢ T1«ShiftRightSigned»T2 : T"
inductive_simps WTrt_binop_simps [simp]:
"P ⊢ T1«Eq»T2 : T"
"P ⊢ T1«NotEq»T2 : T"
"P ⊢ T1«LessThan»T2 : T"
"P ⊢ T1«LessOrEqual»T2 : T"
"P ⊢ T1«GreaterThan»T2 : T"
"P ⊢ T1«GreaterOrEqual»T2 : T"
"P ⊢ T1«Add»T2 : T"
"P ⊢ T1«Subtract»T2 : T"
"P ⊢ T1«Mult»T2 : T"
"P ⊢ T1«Div»T2 : T"
"P ⊢ T1«Mod»T2 : T"
"P ⊢ T1«BinAnd»T2 : T"
"P ⊢ T1«BinOr»T2 : T"
"P ⊢ T1«BinXor»T2 : T"
"P ⊢ T1«ShiftLeft»T2 : T"
"P ⊢ T1«ShiftRightZeros»T2 : T"
"P ⊢ T1«ShiftRightSigned»T2 : T"
fun binop_relevant_class :: "bop ⇒ 'm prog ⇒ cname ⇒ bool"
where
"binop_relevant_class Div = (λP C. P ⊢ ArithmeticException ≼⇧* C )"
| "binop_relevant_class Mod = (λP C. P ⊢ ArithmeticException ≼⇧* C )"
| "binop_relevant_class _ = (λP C. False)"
lemma WT_binop_WTrt_binop:
"P ⊢ T1«bop»T2 :: T ⟹ P ⊢ T1«bop»T2 : T"
by(auto elim: WT_binop.cases)
context heap begin
lemma binop_progress:
"⟦ typeof⇘h⇙ v1 = ⌊T1⌋; typeof⇘h⇙ v2 = ⌊T2⌋; P ⊢ T1«bop»T2 : T ⟧
⟹ ∃va. binop bop v1 v2 = ⌊va⌋"
by(cases bop)(auto del: disjCI split del: if_split)
lemma binop_type:
assumes wf: "wf_prog wf_md P"
and pre: "preallocated h"
and type: "typeof⇘h⇙ v1 = ⌊T1⌋" "typeof⇘h⇙ v2 = ⌊T2⌋" "P ⊢ T1«bop»T2 : T"
shows "binop bop v1 v2 = ⌊Inl v⌋ ⟹ P,h ⊢ v :≤ T"
and "binop bop v1 v2 = ⌊Inr a⌋ ⟹ P,h ⊢ Addr a :≤ Class Throwable"
using type
apply(case_tac [!] bop)
apply(auto split: if_split_asm simp add: conf_def wf_preallocatedD[OF wf pre])
done
lemma binop_relevant_class:
assumes wf: "wf_prog wf_md P"
and pre: "preallocated h"
and bop: "binop bop v1 v2 = ⌊Inr a⌋"
and sup: "P ⊢ cname_of h a ≼⇧* C"
shows "binop_relevant_class bop P C"
using assms
by(cases bop)(auto split: if_split_asm)
end
lemma WTrt_binop_fun: "⟦ P ⊢ T1«bop»T2 : T; P ⊢ T1«bop»T2 : T' ⟧ ⟹ T = T'"
by(cases bop)(auto)
lemma WTrt_binop_THE [simp]: "P ⊢ T1«bop»T2 : T ⟹ The (WTrt_binop P T1 bop T2) = T"
by(auto dest: WTrt_binop_fun)
lemma WTrt_binop_widen_mono:
"⟦ P ⊢ T1«bop»T2 : T; P ⊢ T1' ≤ T1; P ⊢ T2' ≤ T2 ⟧ ⟹ ∃T'. P ⊢ T1'«bop»T2' : T' ∧ P ⊢ T' ≤ T"
by(cases bop)(auto elim!: WTrt_binop_cases)
lemma WTrt_binop_is_type:
"⟦ P ⊢ T1«bop»T2 : T; is_type P T1; is_type P T2 ⟧ ⟹ is_type P T"
by(cases bop) auto
subsection ‹Code generator setup›
lemmas [code] =
heap_base.binop_Div.simps
heap_base.binop_Mod.simps
heap_base.binop.simps
code_pred
(modes: i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool, i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ bool)
WT_binop
.
code_pred
(modes: i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool, i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ bool)
WTrt_binop
.
lemma eval_WTrt_binop_i_i_i_i_o:
"Predicate.eval (WTrt_binop_i_i_i_i_o P T1 bop T2) T ⟷ P ⊢ T1«bop»T2 : T"
by(auto elim: WTrt_binop_i_i_i_i_oE intro: WTrt_binop_i_i_i_i_oI)
lemma the_WTrt_binop_code:
"(THE T. P ⊢ T1«bop»T2 : T) = Predicate.the (WTrt_binop_i_i_i_i_o P T1 bop T2)"
by(simp add: Predicate.the_def eval_WTrt_binop_i_i_i_i_o)
end
Theory SemiType
section ‹The Jinja Type System as a Semilattice›
theory SemiType
imports
WellForm
"../DFA/Semilattices"
begin
inductive_set
widen1 :: "'a prog ⇒ (ty × ty) set"
and widen1_syntax :: "'a prog ⇒ ty ⇒ ty ⇒ bool" ("_ ⊢ _ <⇧1 _" [71,71,71] 70)
for P :: "'a prog"
where
"P ⊢ C <⇧1 D ≡ (C, D) ∈ widen1 P"
| widen1_Array_Object:
"P ⊢ Array (Class Object) <⇧1 Class Object"
| widen1_Array_Integer:
"P ⊢ Array Integer <⇧1 Class Object"
| widen1_Array_Boolean:
"P ⊢ Array Boolean <⇧1 Class Object"
| widen1_Array_Void:
"P ⊢ Array Void <⇧1 Class Object"
| widen1_Class:
"P ⊢ C ≺⇧1 D ⟹ P ⊢ Class C <⇧1 Class D"
| widen1_Array_Array:
"⟦ P ⊢ T <⇧1 U; ¬ is_NT_Array T ⟧ ⟹ P ⊢ Array T <⇧1 Array U"
abbreviation widen1_trancl :: "'a prog ⇒ ty ⇒ ty ⇒ bool" ("_ ⊢ _ <⇧+ _" [71,71,71] 70) where
"P ⊢ T <⇧+ U ≡ (T, U) ∈ trancl (widen1 P)"
abbreviation widen1_rtrancl :: "'a prog ⇒ ty ⇒ ty ⇒ bool" ("_ ⊢ _ <⇧* _" [71,71,71] 70) where
"P ⊢ T <⇧* U ≡ (T, U) ∈ rtrancl (widen1 P)"
inductive_simps widen1_simps1 [simp]:
"P ⊢ Integer <⇧1 T"
"P ⊢ Boolean <⇧1 T"
"P ⊢ Void <⇧1 T"
"P ⊢ Class Object <⇧1 T"
"P ⊢ NT <⇧1 U"
inductive_simps widen1_simps [simp]:
"P ⊢ Array (Class Object) <⇧1 T"
"P ⊢ Array Integer <⇧1 T"
"P ⊢ Array Boolean <⇧1 T"
"P ⊢ Array Void <⇧1 T"
"P ⊢ Class C <⇧1 T"
"P ⊢ T <⇧1 Array U"
lemma is_type_widen1:
assumes icO: "is_class P Object"
shows "P ⊢ T <⇧1 U ⟹ is_type P T"
by(induct rule: widen1.induct)(auto intro: subcls_is_class icO split: ty.split dest: is_type_ground_type)
lemma widen1_NT_Array:
assumes "is_NT_Array T"
shows "¬ P ⊢ T⌊⌉ <⇧1 U"
proof
assume "P ⊢ T⌊⌉ <⇧1 U" thus False using assms
by(induct "T⌊⌉" U arbitrary: T) auto
qed
lemma widen1_is_type:
assumes wfP: "wf_prog wfmd P"
shows "(A, B) ∈ widen1 P ⟹ is_type P B"
proof(induct rule: widen1.induct)
case (widen1_Class C D)
hence "is_class P C" "is_class P D"
by(auto intro: subcls_is_class converse_subcls_is_class[OF wfP])
thus ?case by simp
next
case (widen1_Array_Array T U)
thus ?case by(cases U)(auto elim: widen1.cases)
qed(insert wfP, auto)
lemma widen1_trancl_is_type:
assumes wfP: "wf_prog wfmd P"
shows "(A, B) ∈ (widen1 P)^+ ⟹ is_type P B"
apply(induct rule: trancl_induct)
apply(auto intro: widen1_is_type[OF wfP])
done
lemma single_valued_widen1:
assumes wf: "wf_prog wf_md P"
shows "single_valued (widen1 P)"
proof(rule single_valuedI)
fix x y z
assume "P ⊢ x <⇧1 y" "P ⊢ x <⇧1 z"
thus "y = z"
proof(induct arbitrary: z rule: widen1.induct)
case widen1_Class
with single_valued_subcls1[OF wf] show ?case
by(auto dest: single_valuedpD)
next
case (widen1_Array_Array T U z)
from ‹P ⊢ T⌊⌉ <⇧1 z› ‹P ⊢ T <⇧1 U› ‹¬ is_NT_Array T›
obtain z' where z': "z = z'⌊⌉" and Tz': "P ⊢ T <⇧1 z'"
by(auto elim: widen1.cases)
with ‹P ⊢ T <⇧1 z' ⟹ U = z'› have "U = z'" by blast
with z' show ?case by simp
qed simp_all
qed
function inheritance_level :: "'a prog ⇒ cname ⇒ nat" where
"inheritance_level P C =
(if acyclicP (subcls1 P) ∧ is_class P C ∧ C ≠ Object
then Suc (inheritance_level P (fst (the (class P C))))
else 0)"
by(pat_completeness, auto)
termination
proof(relation "same_fst (λP. acyclicP (subcls1 P)) (λP. {(C, C'). (subcls1 P)¯¯ C C'})")
show "wf (same_fst (λP. acyclicP (subcls1 P)) (λP. {(C, C'). (subcls1 P)¯¯ C C'}))"
by(rule wf_same_fst)(rule acyclicP_wf_subcls1[unfolded wfP_def])
qed(auto simp add: is_class_def intro: subcls1I)
fun subtype_measure :: "'a prog ⇒ ty ⇒ nat" where
"subtype_measure P (Class C) = inheritance_level P C"
| "subtype_measure P (Array T) = 1 + subtype_measure P T"
| "subtype_measure P T = 0"
lemma subtype_measure_measure:
assumes acyclic: "acyclicP (subcls1 P)"
and widen1: "P ⊢ x <⇧1 y"
shows "subtype_measure P y < subtype_measure P x"
using widen1
proof(induct rule: widen1.induct)
case (widen1_Class C D)
then obtain rest where "is_class P C" "C ≠ Object" "class P C = ⌊(D, rest)⌋"
by(auto elim!: subcls1.cases simp: is_class_def)
thus ?case using acyclic by(simp)
qed(simp_all)
lemma wf_converse_widen1:
assumes wfP: "wf_prog wfmc P"
shows "wf ((widen1 P)^-1)"
proof(rule wf_subset)
from wfP have "acyclicP (subcls1 P)" by(rule acyclic_subcls1)
thus "(widen1 P)¯ ⊆ measure (subtype_measure P)"
by(auto dest: subtype_measure_measure)
qed simp
fun super :: "'a prog ⇒ ty ⇒ ty"
where
"super P (Array Integer) = Class Object"
| "super P (Array Boolean) = Class Object"
| "super P (Array Void) = Class Object"
| "super P (Array (Class C)) = (if C = Object then Class Object else Array (super P (Class C)))"
| "super P (Array (Array T)) = Array (super P (Array T))"
| "super P (Class C) = Class (fst (the (class P C)))"
lemma superI:
"P ⊢ T <⇧1 U ⟹ super P T = U"
proof(induct rule: widen1.induct)
case (widen1_Array_Array T U)
thus ?case by(cases T) auto
qed(auto dest: subcls1D)
lemma Class_widen1_super:
"P ⊢ Class C' <⇧1 U' ⟷ is_class P C' ∧ C' ≠ Object ∧ U' = super P (Class C')"
(is "?lhs ⟷ ?rhs")
proof(rule iffI)
assume ?lhs thus ?rhs
by(auto intro: subcls_is_class simp add: superI simp del: super.simps)
next
assume ?rhs thus ?lhs
by(auto simp add: is_class_def intro: subcls1.intros)
qed
lemma super_widen1:
assumes icO: "is_class P Object"
shows "P ⊢ T <⇧1 U ⟷ is_type P T ∧ (case T of Class C ⇒ (C ≠ Object ∧ U = super P T)
| Array T' ⇒ U = super P T
| _ ⇒ False)"
proof(induct T arbitrary: U)
case Class thus ?case using Class_widen1_super by(simp)
next
case (Array T' U')
note IH = this
have "P ⊢ T'⌊⌉ <⇧1 U' = (is_type P (T'⌊⌉) ∧ U' = super P (T'⌊⌉))"
proof(rule iffI)
assume wd: "P ⊢ T'⌊⌉ <⇧1 U'"
with icO have "is_type P (T'⌊⌉)" by(rule is_type_widen1)
moreover from wd have "super P (T'⌊⌉) = U'" by(rule superI)
ultimately show "is_type P (T'⌊⌉) ∧ U' = super P (T'⌊⌉)" by simp
next
assume "is_type P (T'⌊⌉) ∧ U' = super P (T'⌊⌉)"
then obtain "is_type P (T'⌊⌉)" and U': "U' = super P (T'⌊⌉)" ..
thus "P ⊢ T'⌊⌉ <⇧1 U'"
proof(cases T')
case (Class D)
thus ?thesis using U' icO ‹is_type P (T'⌊⌉)›
by(cases "D = Object")(auto simp add: is_class_def intro: subcls1.intros)
next
case Array thus ?thesis
using IH ‹is_type P (T'⌊⌉)› U' by(auto simp add: ty.split_asm)
qed simp_all
qed
thus ?case by(simp)
qed(simp_all)
definition sup :: "'c prog ⇒ ty ⇒ ty ⇒ ty err" where
"sup P T U ≡
if is_refT T ∧ is_refT U
then OK (if U = NT then T
else if T = NT then U
else exec_lub (widen1 P) (super P) T U)
else if (T = U) then OK T else Err"
lemma sup_def':
"sup P = (λT U.
if is_refT T ∧ is_refT U
then OK (if U = NT then T
else if T = NT then U
else exec_lub (widen1 P) (super P) T U)
else if (T = U) then OK T else Err)"
by (simp add: fun_eq_iff sup_def)
definition esl :: "'m prog ⇒ ty esl"
where
"esl P = (types P, widen P, sup P)"
lemma order_widen [intro,simp]:
"wf_prog m P ⟹ order (widen P)"
unfolding Semilat.order_def lesub_def
by (auto intro: widen_trans widen_antisym)
lemma subcls1_trancl_widen1_trancl:
"(subcls1 P)^++ C D ⟹ P ⊢ Class C <⇧+ Class D"
by(induct rule: tranclp_induct[consumes 1, case_names base step])
(auto intro: trancl_into_trancl)
lemma subcls_into_widen1_rtrancl:
"P ⊢ C ≼⇧* D ⟹ P ⊢ Class C <⇧* Class D"
by(induct rule: rtranclp_induct)(auto intro: rtrancl_into_rtrancl)
lemma not_widen1_NT_Array:
"P ⊢ U <⇧1 T ⟹ ¬ is_NT_Array T"
by(induct rule: widen1.induct)(auto)
lemma widen1_trancl_into_Array_widen1_trancl:
"⟦ P ⊢ A <⇧+ B; ¬ is_NT_Array A ⟧ ⟹ P ⊢ A⌊⌉ <⇧+ B⌊⌉"
by(induct rule: converse_trancl_induct)
(auto intro: trancl_into_trancl2 widen1_Array_Array dest: not_widen1_NT_Array)
lemma widen1_rtrancl_into_Array_widen1_rtrancl:
"⟦ P ⊢ A <⇧* B; ¬ is_NT_Array A ⟧ ⟹ P ⊢ A⌊⌉ <⇧* B⌊⌉"
by(blast elim: rtranclE intro: trancl_into_rtrancl widen1_trancl_into_Array_widen1_trancl rtrancl_into_trancl1)
lemma Array_Object_widen1_trancl:
assumes wf: "wf_prog wmdc P"
and itA: "is_type P (A⌊⌉)"
shows "P ⊢ A⌊⌉ <⇧+ Class Object"
using itA
proof(induction A)
case (Class C)
hence "is_class P C" by simp
hence "P ⊢ C ≼⇧* Object" by(rule subcls_C_Object[OF _ wf])
hence "P ⊢ Class C <⇧* Class Object" by(rule subcls_into_widen1_rtrancl)
hence "P ⊢ Class C⌊⌉ <⇧* Class Object⌊⌉"
by(rule widen1_rtrancl_into_Array_widen1_rtrancl) simp
thus ?case by(rule rtrancl_into_trancl1) simp
next
case (Array A)
from ‹is_type P (A⌊⌉⌊⌉)› have "is_type P (A⌊⌉)" by(rule is_type_ArrayD)
hence "P ⊢ A⌊⌉ <⇧+ Class Object" by(rule Array.IH)
moreover from ‹is_type P (A⌊⌉⌊⌉)› have "¬ is_NT_Array (A⌊⌉)" by auto
ultimately have "P ⊢ A⌊⌉⌊⌉ <⇧+ Class Object⌊⌉"
by(rule widen1_trancl_into_Array_widen1_trancl)
thus ?case by(rule trancl_into_trancl) simp
qed auto
lemma widen_into_widen1_trancl:
assumes wf: "wf_prog wfmd P"
shows "⟦ P ⊢ A ≤ B; A ≠ B; A ≠ NT; is_type P A ⟧ ⟹ P ⊢ A <⇧+ B"
proof(induct rule: widen.induct)
case (widen_subcls C D)
from ‹Class C ≠ Class D› ‹P ⊢ C ≼⇧* D› have "(subcls1 P)⇧+⇧+ C D"
by(auto elim: rtranclp.cases intro: rtranclp_into_tranclp1)
thus ?case by(rule subcls1_trancl_widen1_trancl)
next
case widen_array_object thus ?case by(auto intro: Array_Object_widen1_trancl[OF wf])
next
case (widen_array_array A B)
hence "P ⊢ A <⇧+ B" by(cases A) auto
with ‹is_type P (A⌊⌉)› show ?case by(auto intro: widen1_trancl_into_Array_widen1_trancl)
qed(auto)
lemma wf_prog_impl_acc_widen:
assumes wfP: "wf_prog wfmd P"
shows "acc (types P) (widen P)"
proof -
from wf_converse_widen1[OF wfP]
have "wf (((widen1 P)^-1)^+)" by(rule wf_trancl)
hence wfw1t: "⋀M T. T ∈ M ⟹ (∃z∈M. ∀y. (y, z) ∈ ((widen1 P)¯)⇧+ ⟶ y ∉ M)"
by(auto simp only: wf_eq_minimal)
have "wf {(y, x). is_type P x ∧ is_type P y ∧ widen P x y ∧ x ≠ y}"
unfolding wf_eq_minimal
proof(intro strip)
fix M and T :: ty
assume TM: "T ∈ M"
show "∃z∈M. ∀y. (y, z) ∈ {(y, T). is_type P T ∧ is_type P y ∧ widen P T y ∧ T ≠ y} ⟶ y ∉ M"
proof(cases "(∃C. Class C ∈ M ∧ is_class P C) ∨ (∃U. U⌊⌉ ∈ M ∧ is_type P (U⌊⌉))")
case True
have BNTthesis: "⋀B. ⟦ B ∈ (M ∩ types P) - {NT} ⟧ ⟹ ?thesis"
proof -
fix B
assume BM: "B ∈ M ∩ types P - {NT}"
from wfw1t[OF BM] obtain z
where zM: "z ∈ M"
and znnt: "z ≠ NT"
and itz: "is_type P z"
and y: "⋀y. (y, z) ∈ ((widen1 P)¯)⇧+ ⟹ y ∉ M ∩ types P - {NT}" by blast
show "?thesis B"
proof(rule bexI[OF _ zM], rule allI, rule impI)
fix y
assume "(y, z) ∈ {(y, T). is_type P T ∧ is_type P y ∧ widen P T y ∧ T ≠ y}"
hence Pzy: "P ⊢ z ≤ y" and zy: "z ≠ y" and "is_type P y" by auto
hence "P ⊢ z <⇧+ y" using znnt itz
by -(rule widen_into_widen1_trancl[OF wfP])
hence ynM: "y ∉ M ∩ types P - {NT}"
by -(rule y, simp add: trancl_converse)
thus "y ∉ M" using Pzy znnt ‹is_type P y› by auto
qed
qed
from True show ?thesis by(fastforce intro: BNTthesis)
next
case False
hence not_is_class: "⋀C. Class C ∈ M ⟹ ¬ is_class P C"
and not_is_array: "⋀U. U⌊⌉ ∈ M ⟹ ¬ is_type P (U⌊⌉)" by simp_all
show ?thesis
proof(cases "∃C. Class C ∈ M")
case True
then obtain C where "Class C ∈ M" ..
with not_is_class[of C] show ?thesis
by(blast dest: rtranclpD subcls_is_class Class_widen)
next
case False
show ?thesis
proof(cases "∃T. Array T ∈ M")
case True
then obtain U where U: "Array U ∈ M" ..
hence "¬ is_type P (U⌊⌉)" by(rule not_is_array)
thus ?thesis using U by(auto simp del: is_type.simps)
next
case False
with ‹¬ (∃C. Class C ∈ M)› TM
have "∀y. P ⊢ T ≤ y ∧ T ≠ y ⟶ y ∉ M"
by(cases T)(fastforce simp add: NT_widen)+
thus ?thesis using TM by blast
qed
qed
qed
qed
thus ?thesis by(simp add: Semilat.acc_def lesssub_def lesub_def)
qed
lemmas wf_widen_acc = wf_prog_impl_acc_widen
declare wf_widen_acc [intro, simp]
lemma acyclic_widen1:
"wf_prog wfmc P ⟹ acyclic (widen1 P)"
by(auto dest: wf_converse_widen1 wf_acyclic simp add: acyclic_converse)
lemma widen1_into_widen:
"(A, B) ∈ widen1 P ⟹ P ⊢ A ≤ B"
by(induct rule: widen1.induct)(auto intro: widen.intros)
lemma widen1_rtrancl_into_widen:
"P ⊢ A <⇧* B ⟹ P ⊢ A ≤ B"
by(induct rule: rtrancl_induct)(auto dest!: widen1_into_widen elim: widen_trans)
lemma widen_eq_widen1_trancl:
"⟦ wf_prog wf_md P; T ≠ NT; T ≠ U; is_type P T ⟧ ⟹ P ⊢ T ≤ U ⟷ P ⊢ T <⇧+ U"
by(blast intro: widen_into_widen1_trancl widen1_rtrancl_into_widen trancl_into_rtrancl)
lemma sup_is_type:
assumes wf: "wf_prog wf_md P"
and itA: "is_type P A"
and itB: "is_type P B"
and sup: "sup P A B = OK T"
shows "is_type P T"
proof -
{ assume ANT: "A ≠ NT"
and BNT: "B ≠ NT"
and AnB: "A ≠ B"
and RTA: "is_refT A"
and RTB: "is_refT B"
with itA itB have AObject: "P ⊢ A ≤ Class Object"
and BObject: "P ⊢ B ≤ Class Object"
by(auto intro: is_refType_widen_Object[OF wf])
have "is_type P (exec_lub (widen1 P) (super P) A B)"
proof(cases "A = Class Object ∨ B = Class Object")
case True
hence "exec_lub (widen1 P) (super P) A B = Class Object"
proof(rule disjE)
assume A: "A = Class Object"
moreover
from BObject BNT itB have "P ⊢ B <⇧* Class Object"
by(cases "B = Class Object")(auto intro: trancl_into_rtrancl widen_into_widen1_trancl[OF wf])
hence "is_ub ((widen1 P)⇧*) (Class Object) B (Class Object)"
by(auto intro: is_ubI)
hence "is_lub ((widen1 P)⇧*) (Class Object) B (Class Object)"
by(auto simp add: is_lub_def dest: is_ubD)
with acyclic_widen1[OF wf]
have "exec_lub (widen1 P) (super P) (Class Object) B = Class Object"
by(auto intro: exec_lub_conv superI)
ultimately show "exec_lub (widen1 P) (super P) A B = Class Object" by simp
next
assume B: "B = Class Object"
moreover
from AObject ANT itA
have "(A, Class Object) ∈ (widen1 P)⇧*"
by(cases "A = Class Object", auto intro: trancl_into_rtrancl widen_into_widen1_trancl[OF wf])
hence "is_ub ((widen1 P)⇧*) (Class Object) A (Class Object)"
by(auto intro: is_ubI)
hence "is_lub ((widen1 P)⇧*) (Class Object) A (Class Object)"
by(auto simp add: is_lub_def dest: is_ubD)
with acyclic_widen1[OF wf]
have "exec_lub (widen1 P) (super P) A (Class Object) = Class Object"
by(auto intro: exec_lub_conv superI)
ultimately show "exec_lub (widen1 P) (super P) A B = Class Object" by simp
qed
with wf show ?thesis by(simp)
next
case False
hence AnObject: "A ≠ Class Object"
and BnObject: "B ≠ Class Object" by auto
from widen_into_widen1_trancl[OF wf AObject AnObject ANT itA]
have "P ⊢ A <⇧* Class Object" by(rule trancl_into_rtrancl)
moreover from widen_into_widen1_trancl[OF wf BObject BnObject BNT itB]
have "P ⊢ B <⇧* Class Object" by(rule trancl_into_rtrancl)
ultimately have "is_lub ((widen1 P)⇧*) A B (exec_lub (widen1 P) (super P) A B)"
by(rule is_lub_exec_lub[OF single_valued_widen1[OF wf] acyclic_widen1[OF wf]])(auto intro: superI)
hence Aew1: "P ⊢ A <⇧* exec_lub (widen1 P) (super P) A B"
by(auto simp add: is_lub_def dest!: is_ubD)
thus ?thesis
proof(rule rtranclE)
assume "A = exec_lub (widen1 P) (super P) A B"
with itA show ?thesis by simp
next
fix A'
assume "P ⊢ A' <⇧1 exec_lub (widen1 P) (super P) A B"
thus ?thesis by(rule widen1_is_type[OF wf])
qed
qed }
with is_class_Object[OF wf] sup itA itB show ?thesis unfolding sup_def
by(cases "A = B")(auto split: if_split_asm simp add: exec_lub_refl)
qed
lemma closed_err_types:
assumes wfP: "wf_prog wf_mb P"
shows "closed (err (types P)) (lift2 (sup P))"
proof -
{ fix A B
assume it: "is_type P A" "is_type P B"
and "A ≠ NT" "B ≠ NT" "A ≠ B"
and "is_refT A" "is_refT B"
hence "is_type P (exec_lub (widen1 P) (super P) A B)"
using sup_is_type[OF wfP it] by(simp add: sup_def) }
with is_class_Object[OF wfP] show ?thesis
unfolding closed_def plussub_def lift2_def sup_def'
by(auto split: err.split ty.splits)(auto simp add: exec_lub_refl)
qed
lemma widen_into_widen1_rtrancl:
"⟦wf_prog wfmd P; widen P A B; A ≠ NT; is_type P A ⟧ ⟹ (A, B) ∈ (widen1 P)⇧*"
by(cases "A = B")(auto intro: trancl_into_rtrancl widen_into_widen1_trancl)
lemma sup_widen_greater:
assumes wfP: "wf_prog wf_mb P"
and it1: "is_type P t1"
and it2: "is_type P t2"
and sup: "sup P t1 t2 = OK s"
shows "widen P t1 s ∧ widen P t2 s"
proof -
{ assume t1: "is_refT t1"
and t2: "is_refT t2"
and t1NT: "t1 ≠ NT"
and t2NT: "t2 ≠ NT"
with it1 it2 wfP have "P ⊢ t1 ≤ Class Object" "P ⊢ t2 ≤ Class Object"
by(auto intro: is_refType_widen_Object)
with t1NT t2NT it1 it2
have "P ⊢ t1 <⇧* Class Object" "P ⊢ t2 <⇧* Class Object"
by(auto intro: widen_into_widen1_rtrancl[OF wfP])
with single_valued_widen1[OF wfP]
obtain u where "is_lub ((widen1 P)^*) t1 t2 u"
by (blast dest: single_valued_has_lubs)
hence "P ⊢ t1 ≤ exec_lub (widen1 P) (super P) t1 t2 ∧
P ⊢ t2 ≤ exec_lub (widen1 P) (super P) t1 t2"
using acyclic_widen1[OF wfP] superI[of _ _ P]
by(simp add: exec_lub_conv)(blast dest: is_lubD is_ubD intro: widen1_rtrancl_into_widen) }
with it1 it2 sup show ?thesis
by (cases s) (auto simp add: sup_def split: if_split_asm elim: refTE)
qed
lemma sup_widen_smallest:
assumes wfP: "wf_prog wf_mb P"
and itT: "is_type P T"
and itU: "is_type P U"
and TwV: "P ⊢ T ≤ V"
and UwV: "P ⊢ U ≤ V"
and sup: "sup P T U = OK W"
shows "widen P W V"
proof -
{ assume rT: "is_refT T"
and rU: "is_refT U"
and UNT: "U ≠ NT"
and TNT: "T ≠ NT"
and W: "exec_lub (widen1 P) (super P) T U = W"
from itU itT rT rU UNT TNT have "P ⊢ T ≤ Class Object" "P ⊢ U ≤ Class Object"
by(auto intro:is_refType_widen_Object[OF wfP])
with UNT TNT itT itU
have "P ⊢ T <⇧* Class Object" "P ⊢ U <⇧* Class Object"
by(auto intro: widen_into_widen1_rtrancl[OF wfP])
with single_valued_widen1[OF wfP]
obtain X where lub: "is_lub ((widen1 P)^* ) T U X"
by (blast dest: single_valued_has_lubs)
with acyclic_widen1[OF wfP]
have "exec_lub (widen1 P) (super P) T U = X"
by (blast intro: superI exec_lub_conv)
also from TwV TNT UwV UNT itT itU have "P ⊢ T <⇧* V" "P ⊢ U <⇧* V"
by(auto intro: widen_into_widen1_rtrancl[OF wfP])
with lub have "P ⊢ X <⇧* V"
by (clarsimp simp add: is_lub_def is_ub_def)
finally have "P ⊢ exec_lub (widen1 P) (super P) T U ≤ V"
by(rule widen1_rtrancl_into_widen)
with W have "P ⊢ W ≤ V" by simp }
with sup itT itU TwV UwV show ?thesis
by(simp add: sup_def split: if_split_asm)
qed
lemma sup_exists:
"⟦ widen P a c; widen P b c ⟧ ⟹ ∃T. sup P a b = OK T"
by(cases b a rule: ty.exhaust[case_product ty.exhaust])(auto simp add: sup_def)
lemma err_semilat_JType_esl:
assumes wf_prog: "wf_prog wf_mb P"
shows "err_semilat (esl P)"
proof -
from wf_prog have "order (widen P)" ..
moreover from wf_prog
have "closed (err (types P)) (lift2 (sup P))"
by (rule closed_err_types)
moreover
from wf_prog have
"(∀x∈err (types P). ∀y∈err (types P). x ⊑⇘Err.le (widen P)⇙ x ⊔⇘lift2 (sup P)⇙ y) ∧
(∀x∈err (types P). ∀y∈err (types P). y ⊑⇘Err.le (widen P)⇙ x ⊔⇘lift2 (sup P)⇙ y)"
by(auto simp add: lesub_def plussub_def Err.le_def lift2_def sup_widen_greater split: err.split)
moreover from wf_prog have
"∀x∈err (types P). ∀y∈err (types P). ∀z∈err (types P).
x ⊑⇘Err.le (widen P)⇙ z ∧ y ⊑⇘Err.le (widen P)⇙ z ⟶ x ⊔⇘lift2 (sup P)⇙ y ⊑⇘Err.le (widen P)⇙ z"
unfolding lift2_def plussub_def lesub_def Err.le_def
by(auto intro: sup_widen_smallest dest:sup_exists simp add: split: err.split)
ultimately show ?thesis by (simp add: esl_def semilat_def sl_def Err.sl_def)
qed
subsection ‹Relation between @{term "sup P T U = OK V"} and @{term "P ⊢ lub(T, U) = V"}›
lemma sup_is_lubI:
assumes wf: "wf_prog wf_md P"
and it: "is_type P T" "is_type P U"
and sup: "sup P T U = OK V"
shows "P ⊢ lub(T, U) = V"
proof
from sup_widen_greater[OF wf it sup]
show "P ⊢ T ≤ V" "P ⊢ U ≤ V" by blast+
next
fix T'
assume "P ⊢ T ≤ T'" "P ⊢ U ≤ T'"
thus "P ⊢ V ≤ T'" using sup by(rule sup_widen_smallest[OF wf it])
qed
lemma is_lub_subD:
assumes wf: "wf_prog wf_md P"
and it: "is_type P T" "is_type P U"
and lub: "P ⊢ lub(T, U) = V"
shows "sup P T U = OK V"
proof -
from lub have "P ⊢ T ≤ V" "P ⊢ U ≤ V" by(blast dest: is_lub_upper)+
from sup_exists[OF this] obtain W where "sup P T U = OK W" by blast
moreover
with wf it have "P ⊢ lub(T, U) = W" by(rule sup_is_lubI)
with lub have "V = W" by(auto dest: is_lub_unique[OF wf])
ultimately show ?thesis by simp
qed
lemma is_lub_is_type:
"⟦ wf_prog wf_md P; is_type P T; is_type P U; P ⊢ lub(T, U) = V ⟧ ⟹ is_type P V"
by(frule (3) is_lub_subD)(erule (3) sup_is_type)
subsection ‹Code generator setup›
code_pred widen1p .
lemmas [code] = widen1_def
lemma eval_widen1p_i_i_o_conv:
"Predicate.eval (widen1p_i_i_o P T) = (λU. P ⊢ T <⇧1 U)"
by(auto elim: widen1p_i_i_oE intro: widen1p_i_i_oI simp add: widen1_def fun_eq_iff)
lemma rtrancl_widen1_code [code_unfold]:
"(widen1 P)^* = {(a, b). Predicate.holds (rtrancl_tab_FioB_i_i_i (widen1p_i_i_o P) [] a b)}"
by(auto simp add: fun_eq_iff Predicate.holds_eq widen1_def rtrancl_def rtranclp_eq_rtrancl_tab_nil eval_widen1p_i_i_o_conv intro!: rtrancl_tab_FioB_i_i_iI elim!: rtrancl_tab_FioB_i_i_iE)
declare exec_lub_def [code_unfold]
end
Theory State
chapter ‹JinjaThreads source language›
section ‹Program State›
theory State
imports
"../Common/Heap"
begin
type_synonym
'addr locals = "vname ⇀ 'addr val"
type_synonym
('addr, 'heap) Jstate = "'heap × 'addr locals"
definition hp :: "'heap × 'x ⇒ 'heap" where "hp ≡ fst"
definition lcl :: "'heap × 'x ⇒ 'x" where "lcl ≡ snd"
lemma hp_conv [simp]: "hp (h, l) = h"
by(simp add: hp_def)
lemma lcl_conv [simp]: "lcl (h, l) = l"
by(simp add: lcl_def)
end
Theory Expr
section ‹Expressions›
theory Expr
imports
"../Common/BinOp"
begin
datatype (dead 'a, dead 'b, dead 'addr) exp
= new cname
| newArray ty "('a,'b,'addr) exp" ("newA _⌊_⌉" [99,0] 90)
| Cast ty "('a,'b,'addr) exp"
| InstanceOf "('a,'b,'addr) exp" ty ("_ instanceof _" [99, 99] 90)
| Val "'addr val"
| BinOp "('a,'b,'addr) exp" bop "('a,'b,'addr) exp" ("_ «_» _" [80,0,81] 80)
| Var 'a
| LAss 'a "('a,'b,'addr) exp" ("_:=_" [90,90]90)
| AAcc "('a,'b,'addr) exp" "('a,'b,'addr) exp" ("_⌊_⌉" [99,0] 90)
| AAss "('a,'b,'addr) exp" "('a,'b,'addr) exp" "('a,'b,'addr) exp" ("_⌊_⌉ := _" [10,99,90] 90)
| ALen "('a,'b,'addr) exp" ("_∙length" [10] 90)
| FAcc "('a,'b,'addr) exp" vname cname ("_∙_{_}" [10,90,99]90)
| FAss "('a,'b,'addr) exp" vname cname "('a,'b,'addr) exp" ("_∙_{_} := _" [10,90,99,90]90)
| CompareAndSwap "('a,'b,'addr) exp" cname vname "('a,'b,'addr) exp" "('a,'b,'addr) exp" ("_∙compareAndSwap('(_∙_, _, _'))" [10,90,90,90,90] 90)
| Call "('a,'b,'addr) exp" mname "('a,'b,'addr) exp list" ("_∙_'(_')" [90,99,0] 90)
| Block 'a ty "'addr val option" "('a,'b,'addr) exp" ("'{_:_=_; _}")
| Synchronized 'b "('a,'b,'addr) exp" "('a,'b,'addr) exp" ("sync⇘_⇙ '(_') _" [99,99,90] 90)
| InSynchronized 'b 'addr "('a,'b,'addr) exp" ("insync⇘_⇙ '(_') _" [99,99,90] 90)
| Seq "('a,'b,'addr) exp" "('a,'b,'addr) exp" ("_;;/ _" [61,60]60)
| Cond "('a,'b,'addr) exp" "('a,'b,'addr) exp" "('a,'b,'addr) exp" ("if '(_') _/ else _" [80,79,79]70)
| While "('a,'b,'addr) exp" "('a,'b,'addr) exp" ("while '(_') _" [80,79]70)
| throw "('a,'b,'addr) exp"
| TryCatch "('a,'b,'addr) exp" cname 'a "('a,'b,'addr) exp" ("try _/ catch'(_ _') _" [0,99,80,79] 70)
type_synonym
'addr expr = "(vname, unit, 'addr) exp"
type_synonym
'addr J_mb = "vname list × 'addr expr"
type_synonym
'addr J_prog = "'addr J_mb prog"
translations
(type) "'addr expr" <= (type) "(String.literal, unit, 'addr) exp"
(type) "'addr J_prog" <= (type) "(String.literal list × 'addr expr) prog"
subsection "Syntactic sugar"
abbreviation unit :: "('a,'b,'addr) exp"
where "unit ≡ Val Unit"
abbreviation null :: "('a,'b,'addr) exp"
where "null ≡ Val Null"
abbreviation addr :: "'addr ⇒ ('a,'b,'addr) exp"
where "addr a == Val (Addr a)"
abbreviation true :: "('a,'b,'addr) exp"
where "true == Val (Bool True)"
abbreviation false :: "('a,'b,'addr) exp"
where "false == Val (Bool False)"
abbreviation Throw :: "'addr ⇒ ('a,'b,'addr) exp"
where "Throw a == throw (Val (Addr a))"
abbreviation (in heap_base) THROW :: "cname ⇒ ('a,'b,'addr) exp"
where "THROW xc == Throw (addr_of_sys_xcpt xc)"
abbreviation sync_unit_syntax :: "('a,unit,'addr) exp ⇒ ('a,unit,'addr) exp ⇒ ('a,unit,'addr) exp" ("sync'(_') _" [99,90] 90)
where "sync(e1) e2 ≡ sync⇘()⇙ (e1) e2"
abbreviation insync_unit_syntax :: "'addr ⇒ ('a,unit,'addr) exp ⇒ ('a,unit,'addr) exp" ("insync'(_') _" [99,90] 90)
where "insync(a) e2 ≡ insync⇘()⇙ (a) e2"
text ‹Java syntax for binary operators›
abbreviation BinOp_Eq :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «==» _" [80,81] 80)
where "e «==» e' ≡ e «Eq» e'"
abbreviation BinOp_NotEq :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «!=» _" [80,81] 80)
where "e «!=» e' ≡ e «NotEq» e'"
abbreviation BinOp_LessThan :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «<» _" [80,81] 80)
where "e «<» e' ≡ e «LessThan» e'"
abbreviation BinOp_LessOrEqual :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «<=» _" [80,81] 80)
where "e «<=» e' ≡ e «LessOrEqual» e'"
abbreviation BinOp_GreaterThan :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «>» _" [80,81] 80)
where "e «>» e' ≡ e «GreaterThan» e'"
abbreviation BinOp_GreaterOrEqual :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «>=» _" [80,81] 80)
where "e «>=» e' ≡ e «GreaterOrEqual» e'"
abbreviation BinOp_Add :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «+» _" [80,81] 80)
where "e «+» e' ≡ e «Add» e'"
abbreviation BinOp_Subtract :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «-» _" [80,81] 80)
where "e «-» e' ≡ e «Subtract» e'"
abbreviation BinOp_Mult :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «*» _" [80,81] 80)
where "e «*» e' ≡ e «Mult» e'"
abbreviation BinOp_Div :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «'/» _" [80,81] 80)
where "e «/» e' ≡ e «Div» e'"
abbreviation BinOp_Mod :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «%» _" [80,81] 80)
where "e «%» e' ≡ e «Mod» e'"
abbreviation BinOp_BinAnd :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «&» _" [80,81] 80)
where "e «&» e' ≡ e «BinAnd» e'"
abbreviation BinOp_BinOr :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «|» _" [80,81] 80)
where "e «|» e' ≡ e «BinOr» e'"
abbreviation BinOp_BinXor :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «^» _" [80,81] 80)
where "e «^» e' ≡ e «BinXor» e'"
abbreviation BinOp_ShiftLeft :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «<<» _" [80,81] 80)
where "e «<<» e' ≡ e «ShiftLeft» e'"
abbreviation BinOp_ShiftRightZeros :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «>>>» _" [80,81] 80)
where "e «>>>» e' ≡ e «ShiftRightZeros» e'"
abbreviation BinOp_ShiftRightSigned :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «>>» _" [80,81] 80)
where "e «>>» e' ≡ e «ShiftRightSigned» e'"
abbreviation BinOp_CondAnd :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «&&» _" [80,81] 80)
where "e «&&» e' ≡ if (e) e' else false"
abbreviation BinOp_CondOr :: "('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp ⇒ ('a, 'b, 'c) exp"
("_ «||» _" [80,81] 80)
where "e «||» e' ≡ if (e) true else e'"
lemma inj_Val [simp]: "inj Val"
by(rule inj_onI)(simp)
lemma expr_ineqs [simp]: "Val v ;; e ≠ e" "if (e1) e else e2 ≠ e" "if (e1) e2 else e ≠ e"
by(induct e) auto
subsection‹Free Variables›
primrec fv :: "('a,'b,'addr) exp ⇒ 'a set"
and fvs :: "('a,'b,'addr) exp list ⇒ 'a set"
where
"fv(new C) = {}"
| "fv(newA T⌊e⌉) = fv e"
| "fv(Cast C e) = fv e"
| "fv(e instanceof T) = fv e"
| "fv(Val v) = {}"
| "fv(e⇩1 «bop» e⇩2) = fv e⇩1 ∪ fv e⇩2"
| "fv(Var V) = {V}"
| "fv(a⌊i⌉) = fv a ∪ fv i"
| "fv(AAss a i e) = fv a ∪ fv i ∪ fv e"
| "fv(a∙length) = fv a"
| "fv(LAss V e) = {V} ∪ fv e"
| "fv(e∙F{D}) = fv e"
| "fv(FAss e⇩1 F D e⇩2) = fv e⇩1 ∪ fv e⇩2"
| "fv(e⇩1∙compareAndSwap(D∙F, e⇩2, e⇩3)) = fv e⇩1 ∪ fv e⇩2 ∪ fv e⇩3"
| "fv(e∙M(es)) = fv e ∪ fvs es"
| "fv({V:T=vo; e}) = fv e - {V}"
| "fv(sync⇘V⇙ (h) e) = fv h ∪ fv e"
| "fv(insync⇘V⇙ (a) e) = fv e"
| "fv(e⇩1;;e⇩2) = fv e⇩1 ∪ fv e⇩2"
| "fv(if (b) e⇩1 else e⇩2) = fv b ∪ fv e⇩1 ∪ fv e⇩2"
| "fv(while (b) e) = fv b ∪ fv e"
| "fv(throw e) = fv e"
| "fv(try e⇩1 catch(C V) e⇩2) = fv e⇩1 ∪ (fv e⇩2 - {V})"
| "fvs([]) = {}"
| "fvs(e#es) = fv e ∪ fvs es"
lemma [simp]: "fvs(es @ es') = fvs es ∪ fvs es'"
by(induct es) auto
lemma [simp]: "fvs(map Val vs) = {}"
by (induct vs) auto
subsection‹Locks and addresses›
primrec expr_locks :: "('a,'b,'addr) exp ⇒ 'addr ⇒ nat"
and expr_lockss :: "('a,'b,'addr) exp list ⇒ 'addr ⇒ nat"
where
"expr_locks (new C) = (λad. 0)"
| "expr_locks (newA T⌊e⌉) = expr_locks e"
| "expr_locks (Cast T e) = expr_locks e"
| "expr_locks (e instanceof T) = expr_locks e"
| "expr_locks (Val v) = (λad. 0)"
| "expr_locks (Var v) = (λad. 0)"
| "expr_locks (e «bop» e') = (λad. expr_locks e ad + expr_locks e' ad)"
| "expr_locks (V := e) = expr_locks e"
| "expr_locks (a⌊i⌉) = (λad. expr_locks a ad + expr_locks i ad)"
| "expr_locks (AAss a i e) = (λad. expr_locks a ad + expr_locks i ad + expr_locks e ad)"
| "expr_locks (a∙length) = expr_locks a"
| "expr_locks (e∙F{D}) = expr_locks e"
| "expr_locks (FAss e F D e') = (λad. expr_locks e ad + expr_locks e' ad)"
| "expr_locks (e∙compareAndSwap(D∙F, e', e'')) = (λad. expr_locks e ad + expr_locks e' ad + expr_locks e'' ad)"
| "expr_locks (e∙m(ps)) = (λad. expr_locks e ad + expr_lockss ps ad)"
| "expr_locks ({V : T=vo; e}) = expr_locks e"
| "expr_locks (sync⇘V⇙ (o') e) = (λad. expr_locks o' ad + expr_locks e ad)"
| "expr_locks (insync⇘V⇙ (a) e) = (λad. if (a = ad) then Suc (expr_locks e ad) else expr_locks e ad)"
| "expr_locks (e;;e') = (λad. expr_locks e ad + expr_locks e' ad)"
| "expr_locks (if (b) e else e') = (λad. expr_locks b ad + expr_locks e ad + expr_locks e' ad)"
| "expr_locks (while (b) e) = (λad. expr_locks b ad + expr_locks e ad)"
| "expr_locks (throw e) = expr_locks e"
| "expr_locks (try e catch(C v) e') = (λad. expr_locks e ad + expr_locks e' ad)"
| "expr_lockss [] = (λa. 0)"
| "expr_lockss (x#xs) = (λad. expr_locks x ad + expr_lockss xs ad)"
lemma expr_lockss_append [simp]:
"expr_lockss (es @ es') = (λad. expr_lockss es ad + expr_lockss es' ad)"
by(induct es) auto
lemma expr_lockss_map_Val [simp]: "expr_lockss (map Val vs) = (λad. 0)"
by(induct vs) auto
primrec contains_insync :: "('a,'b,'addr) exp ⇒ bool"
and contains_insyncs :: "('a,'b,'addr) exp list ⇒ bool"
where
"contains_insync (new C) = False"
| "contains_insync (newA T⌊i⌉) = contains_insync i"
| "contains_insync (Cast T e) = contains_insync e"
| "contains_insync (e instanceof T) = contains_insync e"
| "contains_insync (Val v) = False"
| "contains_insync (Var v) = False"
| "contains_insync (e «bop» e') = (contains_insync e ∨ contains_insync e')"
| "contains_insync (V := e) = contains_insync e"
| "contains_insync (a⌊i⌉) = (contains_insync a ∨ contains_insync i)"
| "contains_insync (AAss a i e) = (contains_insync a ∨ contains_insync i ∨ contains_insync e)"
| "contains_insync (a∙length) = contains_insync a"
| "contains_insync (e∙F{D}) = contains_insync e"
| "contains_insync (FAss e F D e') = (contains_insync e ∨ contains_insync e')"
| "contains_insync (e∙compareAndSwap(D∙F, e', e'')) = (contains_insync e ∨ contains_insync e' ∨ contains_insync e'')"
| "contains_insync (e∙m(pns)) = (contains_insync e ∨ contains_insyncs pns)"
| "contains_insync ({V : T=vo; e}) = contains_insync e"
| "contains_insync (sync⇘V⇙ (o') e) = (contains_insync o' ∨ contains_insync e)"
| "contains_insync (insync⇘V⇙ (a) e) = True"
| "contains_insync (e;;e') = (contains_insync e ∨ contains_insync e')"
| "contains_insync (if (b) e else e') = (contains_insync b ∨ contains_insync e ∨ contains_insync e')"
| "contains_insync (while (b) e) = (contains_insync b ∨ contains_insync e)"
| "contains_insync (throw e) = contains_insync e"
| "contains_insync (try e catch(C v) e') = (contains_insync e ∨ contains_insync e')"
| "contains_insyncs [] = False"
| "contains_insyncs (x # xs) = (contains_insync x ∨ contains_insyncs xs)"
lemma contains_insyncs_append [simp]:
"contains_insyncs (es @ es') ⟷ contains_insyncs es ∨ contains_insyncs es'"
by(induct es, auto)
lemma fixes e :: "('a, 'b, 'addr) exp"
and es :: "('a, 'b, 'addr) exp list"
shows contains_insync_conv: "(contains_insync e ⟷ (∃ad. expr_locks e ad > 0))"
and contains_insyncs_conv: "(contains_insyncs es ⟷ (∃ad. expr_lockss es ad > 0))"
by(induct e and es rule: expr_locks.induct expr_lockss.induct)(auto)
lemma contains_insyncs_map_Val [simp]: "¬ contains_insyncs (map Val vs)"
by(induct vs) auto
subsection ‹Value expressions›
inductive is_val :: "('a,'b,'addr) exp ⇒ bool" where
"is_val (Val v)"
declare is_val.intros [simp]
declare is_val.cases [elim!]
lemma is_val_iff: "is_val e ⟷ (∃v. e = Val v)"
by(auto)
code_pred is_val .
fun is_vals :: "('a,'b,'addr) exp list ⇒ bool" where
"is_vals [] = True"
| "is_vals (e#es) = (is_val e ∧ is_vals es)"
lemma is_vals_append [simp]: "is_vals (es @ es') ⟷ is_vals es ∧ is_vals es'"
by(induct es) auto
lemma is_vals_conv: "is_vals es = (∃vs. es = map Val vs)"
by(induct es)(auto simp add: Cons_eq_map_conv)
lemma is_vals_map_Vals [simp]: "is_vals (map Val vs) = True"
unfolding is_vals_conv by auto
inductive is_addr :: "('a,'b,'addr) exp ⇒ bool"
where "is_addr (addr a)"
declare is_addr.intros[intro!]
declare is_addr.cases[elim!]
lemma [simp]: "(is_addr e) ⟷ (∃a. e = addr a)"
by auto
primrec the_Val :: "('a, 'b, 'addr) exp ⇒ 'addr val"
where
"the_Val (Val v) = v"
inductive is_Throws :: "('a, 'b, 'addr) exp list ⇒ bool"
where
"is_Throws (Throw a # es)"
| "is_Throws es ⟹ is_Throws (Val v # es)"
inductive_simps is_Throws_simps:
"is_Throws []"
"is_Throws (e # es)"
code_pred is_Throws .
lemma is_Throws_conv: "is_Throws es ⟷ (∃vs a es'. es = map Val vs @ Throw a # es')"
(is "?lhs ⟷ ?rhs")
proof
assume ?lhs thus ?rhs
by(induct)(fastforce simp add: Cons_eq_append_conv Cons_eq_map_conv)+
next
assume ?rhs thus ?lhs
by(induct es)(auto simp add: is_Throws_simps Cons_eq_map_conv Cons_eq_append_conv)
qed
subsection ‹‹blocks››
fun blocks :: "'a list ⇒ ty list ⇒ 'addr val list ⇒ ('a,'b,'addr) exp ⇒ ('a,'b,'addr) exp"
where
"blocks (V # Vs) (T # Ts) (v # vs) e = {V:T=⌊v⌋; blocks Vs Ts vs e}"
| "blocks [] [] [] e = e"
lemma [simp]:
"⟦ size vs = size Vs; size Ts = size Vs ⟧ ⟹ fv (blocks Vs Ts vs e) = fv e - set Vs"
by(induct rule:blocks.induct)(simp_all, blast)
lemma expr_locks_blocks:
"⟦ length vs = length pns; length Ts = length pns ⟧
⟹ expr_locks (blocks pns Ts vs e) = expr_locks e"
by(induct pns Ts vs e rule: blocks.induct)(auto)
subsection ‹Final expressions›
inductive final :: "('a,'b,'addr) exp ⇒ bool" where
"final (Val v)"
| "final (Throw a)"
declare final.cases [elim]
declare final.intros[simp]
lemmas finalE[consumes 1, case_names Val Throw] = final.cases
lemma final_iff: "final e ⟷ (∃v. e = Val v) ∨ (∃a. e = Throw a)"
by(auto)
lemma final_locks: "final e ⟹ expr_locks e l = 0"
by(auto elim: finalE)
inductive finals :: "('a,'b,'addr) exp list ⇒ bool"
where
"finals []"
| "finals (Throw a # es)"
| "finals es ⟹ finals (Val v # es)"
inductive_simps finals_simps:
"finals (e # es)"
lemma [iff]: "finals []"
by(rule finals.intros)
lemma [iff]: "finals (Val v # es) = finals es"
by(simp add: finals_simps)
lemma finals_app_map [iff]: "finals (map Val vs @ es) = finals es"
by(induct vs) simp_all
lemma [iff]: "finals (throw e # es) = (∃a. e = addr a)"
by(simp add: finals_simps)
lemma not_finals_ConsI: "¬ final e ⟹ ¬ finals (e # es)"
by(simp add: finals_simps final_iff)
lemma finals_iff: "finals es ⟷ (∃vs. es = map Val vs) ∨ (∃vs a es'. es = map Val vs @ Throw a # es')"
(is "?lhs ⟷ ?rhs")
proof
assume ?lhs thus ?rhs
by induct(auto simp add: Cons_eq_append_conv Cons_eq_map_conv, metis)
next
assume ?rhs thus ?lhs by(induct es) auto
qed
code_pred final .
subsection ‹converting results from external calls›
primrec extRet2J :: "('a, 'b, 'addr) exp ⇒ 'addr extCallRet ⇒ ('a, 'b, 'addr) exp"
where
"extRet2J e (RetVal v) = Val v"
| "extRet2J e (RetExc a) = Throw a"
| "extRet2J e RetStaySame = e"
lemma fv_extRet2J [simp]: "fv (extRet2J e va) ⊆ fv e"
by(cases va) simp_all
subsection ‹expressions at a call›
primrec call :: "('a,'b,'addr) exp ⇒ ('addr × mname × 'addr val list) option"
and calls :: "('a,'b,'addr) exp list ⇒ ('addr × mname × 'addr val list) option"
where
"call (new C) = None"
| "call (newA T⌊e⌉) = call e"
| "call (Cast C e) = call e"
| "call (e instanceof T) = call e"
| "call (Val v) = None"
| "call (Var V) = None"
| "call (V:=e) = call e"
| "call (e «bop» e') = (if is_val e then call e' else call e)"
| "call (a⌊i⌉) = (if is_val a then call i else call a)"
| "call (AAss a i e) = (if is_val a then (if is_val i then call e else call i) else call a)"
| "call (a∙length) = call a"
| "call (e∙F{D}) = call e"
| "call (FAss e F D e') = (if is_val e then call e' else call e)"
| "call (e∙compareAndSwap(D∙F, e', e'')) = (if is_val e then if is_val e' then call e'' else call e' else call e)"
| "call (e∙M(es)) = (if is_val e then
(if is_vals es ∧ is_addr e then ⌊(THE a. e = addr a, M, THE vs. es = map Val vs)⌋ else calls es)
else call e)"
| "call ({V:T=vo; e}) = call e"
| "call (sync⇘V⇙ (o') e) = call o'"
| "call (insync⇘V⇙ (a) e) = call e"
| "call (e;;e') = call e"
| "call (if (e) e1 else e2) = call e"
| "call (while(b) e) = None"
| "call (throw e) = call e"
| "call (try e1 catch(C V) e2) = call e1"
| "calls [] = None"
| "calls (e#es) = (if is_val e then calls es else call e)"
lemma calls_append [simp]:
"calls (es @ es') = (if calls es = None ∧ is_vals es then calls es' else calls es)"
by(induct es) auto
lemma call_callE [consumes 1, case_names CallObj CallParams Call]:
"⟦ call (obj∙M(pns)) = ⌊(a, M', vs)⌋;
call obj = ⌊(a, M', vs)⌋ ⟹ thesis;
⋀v. ⟦ obj = Val v; calls pns = ⌊(a, M', vs)⌋ ⟧ ⟹ thesis;
⟦ obj = addr a; pns = map Val vs; M = M' ⟧ ⟹ thesis ⟧ ⟹ thesis"
by(auto split: if_split_asm simp add: is_vals_conv)
lemma calls_map_Val [simp]:
"calls (map Val vs) = None"
by(induct vs) auto
lemma call_not_is_val [dest]: "call e = ⌊aMvs⌋ ⟹ ¬ is_val e"
by(cases e) auto
lemma is_calls_not_is_vals [dest]: "calls es = ⌊aMvs⌋ ⟹ ¬ is_vals es"
by(induct es) auto
end
Theory JHeap
section ‹Abstract heap locales for source code programs›
theory JHeap
imports
"../Common/Conform"
Expr
begin
locale J_heap_base = heap_base +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
locale J_heap = heap +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and P :: "'addr J_prog"
sublocale J_heap < J_heap_base .
locale J_heap_conf_base = heap_conf_base +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and hconf :: "'heap ⇒ bool"
and P :: "'addr J_prog"
sublocale J_heap_conf_base < J_heap_base .
locale J_heap_conf =
J_heap_conf_base +
heap_conf +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and hconf :: "'heap ⇒ bool"
and P :: "'addr J_prog"
sublocale J_heap_conf < J_heap
by(unfold_locales)
locale J_progress =
heap_progress +
J_heap_conf_base +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and hconf :: "'heap ⇒ bool"
and P :: "'addr J_prog"
sublocale J_progress < J_heap by(unfold_locales)
locale J_conf_read =
heap_conf_read +
J_heap_conf +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and hconf :: "'heap ⇒ bool"
and P :: "'addr J_prog"
sublocale J_conf_read < J_heap by(unfold_locales)
locale J_typesafe =
heap_typesafe +
J_conf_read +
J_progress +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and hconf :: "'heap ⇒ bool"
and P :: "'addr J_prog"
end
Theory SmallStep
section ‹Small Step Semantics›
theory SmallStep
imports
Expr
State
JHeap
begin
type_synonym
('addr, 'thread_id, 'heap) J_thread_action =
"('addr, 'thread_id, 'addr expr × 'addr locals,'heap) Jinja_thread_action"
type_synonym
('addr, 'thread_id, 'heap) J_state =
"('addr,'thread_id,'addr expr × 'addr locals,'heap,'addr) state"
print_translation ‹
let
fun tr'
[a1, t
, Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax "exp"}, _) $
Const (@{type_syntax "String.literal"}, _) $ Const (@{type_syntax "unit"}, _) $ a2) $
(Const (@{type_syntax "fun"}, _) $
Const (@{type_syntax "String.literal"}, _) $
(Const (@{type_syntax "option"}, _) $
(Const (@{type_syntax "val"}, _) $ a3)))
, h] =
if a1 = a2 andalso a2 = a3 then Syntax.const @{type_syntax "J_thread_action"} $ a1 $ t $ h
else raise Match;
in [(@{type_syntax "Jinja_thread_action"}, K tr')]
end
›
typ "('addr,'thread_id,'heap) J_thread_action"
print_translation ‹
let
fun tr'
[a1, t
, Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax "exp"}, _) $
Const (@{type_syntax "String.literal"}, _) $ Const (@{type_syntax "unit"}, _) $ a2) $
(Const (@{type_syntax "fun"}, _) $
Const (@{type_syntax "String.literal"}, _) $
(Const (@{type_syntax "option"}, _) $
(Const (@{type_syntax "val"}, _) $ a3)))
, h, a4] =
if a1 = a2 andalso a2 = a3 andalso a3 = a4 then Syntax.const @{type_syntax "J_state"} $ a1 $ t $ h
else raise Match;
in [(@{type_syntax "state"}, K tr')]
end
›
typ "('addr, 'thread_id, 'heap) J_state"
definition extNTA2J :: "'addr J_prog ⇒ (cname × mname × 'addr) ⇒ 'addr expr × 'addr locals"
where "extNTA2J P = (λ(C, M, a). let (D,Ts,T,meth) = method P C M; (pns,body) = the meth
in ({this:Class D=⌊Addr a⌋; body}, Map.empty))"
abbreviation J_local_start ::
"cname ⇒ mname ⇒ ty list ⇒ ty ⇒ 'addr J_mb ⇒ 'addr val list
⇒ 'addr expr × 'addr locals"
where
"J_local_start ≡
λC M Ts T (pns, body) vs.
(blocks (this # pns) (Class C # Ts) (Null # vs) body, Map.empty)"
abbreviation (in J_heap_base)
J_start_state :: "'addr J_prog ⇒ cname ⇒ mname ⇒ 'addr val list ⇒ ('addr, 'thread_id, 'heap) J_state"
where
"J_start_state ≡ start_state J_local_start"
lemma extNTA2J_iff [simp]:
"extNTA2J P (C, M, a) = ({this:Class (fst (method P C M))=⌊Addr a⌋; snd (the (snd (snd (snd (method P C M)))))}, Map.empty)"
by(simp add: extNTA2J_def split_beta)
abbreviation extTA2J ::
"'addr J_prog ⇒ ('addr, 'thread_id, 'heap) external_thread_action ⇒ ('addr, 'thread_id, 'heap) J_thread_action"
where "extTA2J P ≡ convert_extTA (extNTA2J P)"
lemma extTA2J_ε: "extTA2J P ε = ε"
by(simp)
text‹Locking mechanism:
The expression on which the thread is synchronized is evaluated first to a value.
If this expression evaluates to null, a null pointer expression is thrown.
If this expression evaluates to an address, a lock must be obtained on this address, the
sync expression is rewritten to insync.
For insync expressions, the body expression may be evaluated.
If the body expression is only a value or a thrown exception, the lock is released and
the synchronized expression reduces to the body's expression. This is the normal Java semantics,
not the one as presented in LNCS 1523, Cenciarelli/Knapp/Reus/Wirsing. There
the expression on which the thread synchronized is evaluated except for the last step.
If the thread can obtain the lock on the object immediately after the last evaluation step, the evaluation is
done and the lock acquired. If the lock cannot be obtained, the evaluation step is discarded. If another thread
changes the evaluation result of this last step, the thread then will try to synchronize on the new object.›
context J_heap_base begin
inductive red ::
"(('addr, 'thread_id, 'heap) external_thread_action ⇒ ('addr, 'thread_id, 'x,'heap) Jinja_thread_action)
⇒ 'addr J_prog ⇒ 'thread_id
⇒ 'addr expr ⇒ ('addr, 'heap) Jstate
⇒ ('addr, 'thread_id, 'x,'heap) Jinja_thread_action
⇒ 'addr expr ⇒ ('addr, 'heap) Jstate ⇒ bool"
("_,_,_ ⊢ ((1⟨_,/_⟩) -_→/ (1⟨_,/_⟩))" [51,51,0,0,0,0,0,0] 81)
and reds ::
"(('addr, 'thread_id, 'heap) external_thread_action ⇒ ('addr, 'thread_id, 'x,'heap) Jinja_thread_action)
⇒ 'addr J_prog ⇒ 'thread_id
⇒ 'addr expr list ⇒ ('addr, 'heap) Jstate
⇒ ('addr, 'thread_id, 'x,'heap) Jinja_thread_action
⇒ 'addr expr list ⇒ ('addr, 'heap) Jstate ⇒ bool"
("_,_,_ ⊢ ((1⟨_,/_⟩) [-_→]/ (1⟨_,/_⟩))" [51,51,0,0,0,0,0,0] 81)
for extTA :: "('addr, 'thread_id, 'heap) external_thread_action ⇒ ('addr, 'thread_id, 'x, 'heap) Jinja_thread_action"
and P :: "'addr J_prog" and t :: 'thread_id
where
RedNew:
"(h', a) ∈ allocate h (Class_type C)
⟹ extTA,P,t ⊢ ⟨new C, (h, l)⟩ -⦃NewHeapElem a (Class_type C)⦄→ ⟨addr a, (h', l)⟩"
| RedNewFail:
"allocate h (Class_type C) = {}
⟹ extTA,P,t ⊢ ⟨new C, (h, l)⟩ -ε→ ⟨THROW OutOfMemory, (h, l)⟩"
| NewArrayRed:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨newA T⌊e⌉, s⟩ -ta→ ⟨newA T⌊e'⌉, s'⟩"
| RedNewArray:
"⟦ 0 <=s i; (h', a) ∈ allocate h (Array_type T (nat (sint i))) ⟧
⟹ extTA,P,t ⊢ ⟨newA T⌊Val (Intg i)⌉, (h, l)⟩ -⦃NewHeapElem a (Array_type T (nat (sint i)))⦄→ ⟨addr a, (h', l)⟩"
| RedNewArrayNegative:
"i <s 0 ⟹ extTA,P,t ⊢ ⟨newA T⌊Val (Intg i)⌉, s⟩ -ε→ ⟨THROW NegativeArraySize, s⟩"
| RedNewArrayFail:
"⟦ 0 <=s i; allocate h (Array_type T (nat (sint i))) = {} ⟧
⟹ extTA,P,t ⊢ ⟨newA T⌊Val (Intg i)⌉, (h, l)⟩ -ε→ ⟨THROW OutOfMemory, (h, l)⟩"
| CastRed:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨Cast C e, s⟩ -ta→ ⟨Cast C e', s'⟩"
| RedCast:
"⟦ typeof⇘hp s⇙ v = ⌊U⌋; P ⊢ U ≤ T ⟧
⟹ extTA,P,t ⊢ ⟨Cast T (Val v), s⟩ -ε→ ⟨Val v, s⟩"
| RedCastFail:
"⟦ typeof⇘hp s⇙ v = ⌊U⌋; ¬ P ⊢ U ≤ T ⟧
⟹ extTA,P,t ⊢ ⟨Cast T (Val v), s⟩ -ε→ ⟨THROW ClassCast, s⟩"
| InstanceOfRed:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨e instanceof T, s⟩ -ta→ ⟨e' instanceof T, s'⟩"
| RedInstanceOf:
"⟦ typeof⇘hp s⇙ v = ⌊U⌋; b ⟷ v ≠ Null ∧ P ⊢ U ≤ T ⟧
⟹ extTA,P,t ⊢ ⟨(Val v) instanceof T, s⟩ -ε→ ⟨Val (Bool b), s⟩"
| BinOpRed1:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨e «bop» e2, s⟩ -ta→ ⟨e' «bop» e2, s'⟩"
| BinOpRed2:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨(Val v) «bop» e, s⟩ -ta→ ⟨(Val v) «bop» e', s'⟩"
| RedBinOp:
"binop bop v1 v2 = Some (Inl v) ⟹
extTA,P,t ⊢ ⟨(Val v1) «bop» (Val v2), s⟩ -ε→ ⟨Val v, s⟩"
| RedBinOpFail:
"binop bop v1 v2 = Some (Inr a) ⟹
extTA,P,t ⊢ ⟨(Val v1) «bop» (Val v2), s⟩ -ε→ ⟨Throw a, s⟩"
| RedVar:
"lcl s V = Some v ⟹
extTA,P,t ⊢ ⟨Var V, s⟩ -ε→ ⟨Val v, s⟩"
| LAssRed:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨V:=e, s⟩ -ta→ ⟨V:=e', s'⟩"
| RedLAss:
"extTA,P,t ⊢ ⟨V:=(Val v), (h, l)⟩ -ε→ ⟨unit, (h, l(V ↦ v))⟩"
| AAccRed1:
"extTA,P,t ⊢ ⟨a, s⟩ -ta→ ⟨a', s'⟩ ⟹ extTA,P,t ⊢ ⟨a⌊i⌉, s⟩ -ta→ ⟨a'⌊i⌉, s'⟩"
| AAccRed2:
"extTA,P,t ⊢ ⟨i, s⟩ -ta→ ⟨i', s'⟩ ⟹ extTA,P,t ⊢ ⟨(Val a)⌊i⌉, s⟩ -ta→ ⟨(Val a)⌊i'⌉, s'⟩"
| RedAAccNull:
"extTA,P,t ⊢ ⟨null⌊Val i⌉, s⟩ -ε→ ⟨THROW NullPointer, s⟩"
| RedAAccBounds:
"⟦ typeof_addr (hp s) a = ⌊Array_type T n⌋; i <s 0 ∨ sint i ≥ int n ⟧
⟹ extTA,P,t ⊢ ⟨(addr a)⌊Val (Intg i)⌉, s⟩ -ε→ ⟨THROW ArrayIndexOutOfBounds, s⟩"
| RedAAcc:
"⟦ typeof_addr h a = ⌊Array_type T n⌋; 0 <=s i; sint i < int n;
heap_read h a (ACell (nat (sint i))) v ⟧
⟹ extTA,P,t ⊢ ⟨(addr a)⌊Val (Intg i)⌉, (h, l)⟩ -⦃ReadMem a (ACell (nat (sint i))) v⦄→ ⟨Val v, (h, l)⟩"
| AAssRed1:
"extTA,P,t ⊢ ⟨a, s⟩ -ta→ ⟨a', s'⟩ ⟹ extTA,P,t ⊢ ⟨a⌊i⌉ := e, s⟩ -ta→ ⟨a'⌊i⌉ := e, s'⟩"
| AAssRed2:
"extTA,P,t ⊢ ⟨i, s⟩ -ta→ ⟨i', s'⟩ ⟹ extTA,P,t ⊢ ⟨(Val a)⌊i⌉ := e, s⟩ -ta→ ⟨(Val a)⌊i'⌉ := e, s'⟩"
| AAssRed3:
"extTA,P,t ⊢ ⟨(e::'addr expr), s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨(Val a)⌊Val i⌉ := e, s⟩ -ta→ ⟨(Val a)⌊Val i⌉ := e', s'⟩"
| RedAAssNull:
"extTA,P,t ⊢ ⟨null⌊Val i⌉ := (Val e::'addr expr), s⟩ -ε→ ⟨THROW NullPointer, s⟩"
| RedAAssBounds:
"⟦ typeof_addr (hp s) a = ⌊Array_type T n⌋; i <s 0 ∨ sint i ≥ int n ⟧
⟹ extTA,P,t ⊢ ⟨(addr a)⌊Val (Intg i)⌉ := (Val e::'addr expr), s⟩ -ε→ ⟨THROW ArrayIndexOutOfBounds, s⟩"
| RedAAssStore:
"⟦ typeof_addr (hp s) a = ⌊Array_type T n⌋; 0 <=s i; sint i < int n;
typeof⇘hp s⇙ w = ⌊U⌋; ¬ (P ⊢ U ≤ T) ⟧
⟹ extTA,P,t ⊢ ⟨(addr a)⌊Val (Intg i)⌉ := (Val w::'addr expr), s⟩ -ε→ ⟨THROW ArrayStore, s⟩"
| RedAAss:
"⟦ typeof_addr h a = ⌊Array_type T n⌋; 0 <=s i; sint i < int n; typeof⇘h⇙ w = Some U; P ⊢ U ≤ T;
heap_write h a (ACell (nat (sint i))) w h' ⟧
⟹ extTA,P,t ⊢ ⟨(addr a)⌊Val (Intg i)⌉ := Val w::'addr expr, (h, l)⟩ -⦃WriteMem a (ACell (nat (sint i))) w⦄→ ⟨unit, (h', l)⟩"
| ALengthRed:
"extTA,P,t ⊢ ⟨a, s⟩ -ta→ ⟨a', s'⟩ ⟹ extTA,P,t ⊢ ⟨a∙length, s⟩ -ta→ ⟨a'∙length, s'⟩"
| RedALength:
"typeof_addr h a = ⌊Array_type T n⌋
⟹ extTA,P,t ⊢ ⟨addr a∙length, (h, l)⟩ -ε→ ⟨Val (Intg (word_of_nat n)), (h, l)⟩"
| RedALengthNull:
"extTA,P,t ⊢ ⟨null∙length, s⟩ -ε→ ⟨THROW NullPointer, s⟩"
| FAccRed:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨e∙F{D}, s⟩ -ta→ ⟨e'∙F{D}, s'⟩"
| RedFAcc:
"heap_read h a (CField D F) v
⟹ extTA,P,t ⊢ ⟨(addr a)∙F{D}, (h, l)⟩ -⦃ReadMem a (CField D F) v⦄→ ⟨Val v, (h, l)⟩"
| RedFAccNull:
"extTA,P,t ⊢ ⟨null∙F{D}, s⟩ -ε→ ⟨THROW NullPointer, s⟩"
| FAssRed1:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨e∙F{D}:=e2, s⟩ -ta→ ⟨e'∙F{D}:=e2, s'⟩"
| FAssRed2:
"extTA,P,t ⊢ ⟨(e::'addr expr), s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨Val v∙F{D}:=e, s⟩ -ta→ ⟨Val v∙F{D}:=e', s'⟩"
| RedFAss:
"heap_write h a (CField D F) v h' ⟹
extTA,P,t ⊢ ⟨(addr a)∙F{D}:= Val v, (h, l)⟩ -⦃WriteMem a (CField D F) v⦄→ ⟨unit, (h', l)⟩"
| RedFAssNull:
"extTA,P,t ⊢ ⟨null∙F{D}:=Val v::'addr expr, s⟩ -ε→ ⟨THROW NullPointer, s⟩"
| CASRed1:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹
extTA,P,t ⊢ ⟨e∙compareAndSwap(D∙F, e2, e3), s⟩ -ta→ ⟨e'∙compareAndSwap(D∙F, e2, e3), s'⟩"
| CASRed2:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹
extTA,P,t ⊢ ⟨Val v∙compareAndSwap(D∙F, e, e3), s⟩ -ta→ ⟨Val v∙compareAndSwap(D∙F, e', e3), s'⟩"
| CASRed3:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹
extTA,P,t ⊢ ⟨Val v∙compareAndSwap(D∙F, Val v', e), s⟩ -ta→ ⟨Val v∙compareAndSwap(D∙F, Val v', e'), s'⟩"
| CASNull:
"extTA,P,t ⊢ ⟨null∙compareAndSwap(D∙F, Val v, Val v'), s⟩ -ε→ ⟨THROW NullPointer, s⟩"
| RedCASSucceed:
"⟦ heap_read h a (CField D F) v; heap_write h a (CField D F) v' h' ⟧ ⟹
extTA,P,t ⊢ ⟨addr a∙compareAndSwap(D∙F, Val v, Val v'), (h, l)⟩
-⦃ReadMem a (CField D F) v, WriteMem a (CField D F) v'⦄→
⟨true, (h', l)⟩"
| RedCASFail:
"⟦ heap_read h a (CField D F) v''; v ≠ v'' ⟧ ⟹
extTA,P,t ⊢ ⟨addr a∙compareAndSwap(D∙F, Val v, Val v'), (h, l)⟩
-⦃ReadMem a (CField D F) v''⦄→
⟨false, (h, l)⟩"
| CallObj:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨e∙M(es), s⟩ -ta→ ⟨e'∙M(es), s'⟩"
| CallParams:
"extTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es',s'⟩ ⟹
extTA,P,t ⊢ ⟨(Val v)∙M(es),s⟩ -ta→ ⟨(Val v)∙M(es'),s'⟩"
| RedCall:
"⟦ typeof_addr (hp s) a = ⌊hU⌋; P ⊢ class_type_of hU sees M:Ts→T = ⌊(pns,body)⌋ in D;
size vs = size pns; size Ts = size pns ⟧
⟹ extTA,P,t ⊢ ⟨(addr a)∙M(map Val vs), s⟩ -ε→ ⟨blocks (this # pns) (Class D # Ts) (Addr a # vs) body, s⟩"
| RedCallExternal:
"⟦ typeof_addr (hp s) a = ⌊hU⌋; P ⊢ class_type_of hU sees M:Ts→T = Native in D;
P,t ⊢ ⟨a∙M(vs), hp s⟩ -ta→ext ⟨va, h'⟩;
ta' = extTA ta; e' = extRet2J ((addr a)∙M(map Val vs)) va; s' = (h', lcl s) ⟧
⟹ extTA,P,t ⊢ ⟨(addr a)∙M(map Val vs), s⟩ -ta'→ ⟨e', s'⟩"
| RedCallNull:
"extTA,P,t ⊢ ⟨null∙M(map Val vs), s⟩ -ε→ ⟨THROW NullPointer, s⟩"
| BlockRed:
"extTA,P,t ⊢ ⟨e, (h, l(V:=vo))⟩ -ta→ ⟨e', (h', l')⟩
⟹ extTA,P,t ⊢ ⟨{V:T=vo; e}, (h, l)⟩ -ta→ ⟨{V:T=l' V; e'}, (h', l'(V := l V))⟩"
| RedBlock:
"extTA,P,t ⊢ ⟨{V:T=vo; Val u}, s⟩ -ε→ ⟨Val u, s⟩"
| SynchronizedRed1:
"extTA,P,t ⊢ ⟨o', s⟩ -ta→ ⟨o'', s'⟩ ⟹ extTA,P,t ⊢ ⟨sync(o') e, s⟩ -ta→ ⟨sync(o'') e, s'⟩"
| SynchronizedNull:
"extTA,P,t ⊢ ⟨sync(null) e, s⟩ -ε→ ⟨THROW NullPointer, s⟩"
| LockSynchronized:
"extTA,P,t ⊢ ⟨sync(addr a) e, s⟩ -⦃Lock→a, SyncLock a⦄→ ⟨insync(a) e, s⟩"
| SynchronizedRed2:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨insync(a) e, s⟩ -ta→ ⟨insync(a) e', s'⟩"
| UnlockSynchronized:
"extTA,P,t ⊢ ⟨insync(a) (Val v), s⟩ -⦃Unlock→a, SyncUnlock a⦄→ ⟨Val v, s⟩"
| SeqRed:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨e;;e2, s⟩ -ta→ ⟨e';;e2, s'⟩"
| RedSeq:
"extTA,P,t ⊢ ⟨(Val v);;e, s⟩ -ε→ ⟨e, s⟩"
| CondRed:
"extTA,P,t ⊢ ⟨b, s⟩ -ta→ ⟨b', s'⟩ ⟹ extTA,P,t ⊢ ⟨if (b) e1 else e2, s⟩ -ta→ ⟨if (b') e1 else e2, s'⟩"
| RedCondT:
"extTA,P,t ⊢ ⟨if (true) e1 else e2, s⟩ -ε→ ⟨e1, s⟩"
| RedCondF:
"extTA,P,t ⊢ ⟨if (false) e1 else e2, s⟩ -ε→ ⟨e2, s⟩"
| RedWhile:
"extTA,P,t ⊢ ⟨while(b) c, s⟩ -ε→ ⟨if (b) (c;;while(b) c) else unit, s⟩"
| ThrowRed:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨throw e, s⟩ -ta→ ⟨throw e', s'⟩"
| RedThrowNull:
"extTA,P,t ⊢ ⟨throw null, s⟩ -ε→ ⟨THROW NullPointer, s⟩"
| TryRed:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨try e catch(C V) e2, s⟩ -ta→ ⟨try e' catch(C V) e2, s'⟩"
| RedTry:
"extTA,P,t ⊢ ⟨try (Val v) catch(C V) e2, s⟩ -ε→ ⟨Val v, s⟩"
| RedTryCatch:
"⟦ typeof_addr (hp s) a = ⌊Class_type D⌋; P ⊢ D ≼⇧* C ⟧
⟹ extTA,P,t ⊢ ⟨try (Throw a) catch(C V) e2, s⟩ -ε→ ⟨{V:Class C=⌊Addr a⌋; e2}, s⟩"
| RedTryFail:
"⟦ typeof_addr (hp s) a = ⌊Class_type D⌋; ¬ P ⊢ D ≼⇧* C ⟧
⟹ extTA,P,t ⊢ ⟨try (Throw a) catch(C V) e2, s⟩ -ε→ ⟨Throw a, s⟩"
| ListRed1:
"extTA,P,t ⊢ ⟨e,s⟩ -ta→ ⟨e',s'⟩ ⟹
extTA,P,t ⊢ ⟨e#es,s⟩ [-ta→] ⟨e'#es,s'⟩"
| ListRed2:
"extTA,P,t ⊢ ⟨es,s⟩ [-ta→] ⟨es',s'⟩ ⟹
extTA,P,t ⊢ ⟨Val v # es,s⟩ [-ta→] ⟨Val v # es',s'⟩"
| NewArrayThrow: "extTA,P,t ⊢ ⟨newA T⌊Throw a⌉, s⟩ -ε→ ⟨Throw a, s⟩"
| CastThrow: "extTA,P,t ⊢ ⟨Cast C (Throw a), s⟩ -ε→ ⟨Throw a, s⟩"
| InstanceOfThrow: "extTA,P,t ⊢ ⟨(Throw a) instanceof T, s⟩ -ε→ ⟨Throw a, s⟩"
| BinOpThrow1: "extTA,P,t ⊢ ⟨(Throw a) «bop» e⇩2, s⟩ -ε→ ⟨Throw a, s⟩"
| BinOpThrow2: "extTA,P,t ⊢ ⟨(Val v⇩1) «bop» (Throw a), s⟩ -ε→ ⟨Throw a, s⟩"
| LAssThrow: "extTA,P,t ⊢ ⟨V:=(Throw a), s⟩ -ε→ ⟨Throw a, s⟩"
| AAccThrow1: "extTA,P,t ⊢ ⟨(Throw a)⌊i⌉, s⟩ -ε→ ⟨Throw a, s⟩"
| AAccThrow2: "extTA,P,t ⊢ ⟨(Val v)⌊Throw a⌉, s⟩ -ε→ ⟨Throw a, s⟩"
| AAssThrow1: "extTA,P,t ⊢ ⟨(Throw a)⌊i⌉ := e, s⟩ -ε→ ⟨Throw a, s⟩"
| AAssThrow2: "extTA,P,t ⊢ ⟨(Val v)⌊Throw a⌉ := e, s⟩ -ε→ ⟨Throw a, s⟩"
| AAssThrow3: "extTA,P,t ⊢ ⟨(Val v)⌊Val i⌉ := Throw a :: 'addr expr, s⟩ -ε→ ⟨Throw a, s⟩"
| ALengthThrow: "extTA,P,t ⊢ ⟨(Throw a)∙length, s⟩ -ε→ ⟨Throw a, s⟩"
| FAccThrow: "extTA,P,t ⊢ ⟨(Throw a)∙F{D}, s⟩ -ε→ ⟨Throw a, s⟩"
| FAssThrow1: "extTA,P,t ⊢ ⟨(Throw a)∙F{D}:=e⇩2, s⟩ -ε→ ⟨Throw a, s⟩"
| FAssThrow2: "extTA,P,t ⊢ ⟨Val v∙F{D}:=(Throw a::'addr expr), s⟩ -ε→ ⟨Throw a, s⟩"
| CASThrow: "extTA,P,t ⊢ ⟨Throw a∙compareAndSwap(D∙F, e2, e3), s⟩ -ε→ ⟨Throw a, s⟩"
| CASThrow2: "extTA,P,t ⊢ ⟨Val v∙compareAndSwap(D∙F, Throw a, e3), s⟩ -ε→ ⟨Throw a, s⟩"
| CASThrow3: "extTA,P,t ⊢ ⟨Val v∙compareAndSwap(D∙F, Val v', Throw a), s⟩ -ε→ ⟨Throw a, s⟩"
| CallThrowObj: "extTA,P,t ⊢ ⟨(Throw a)∙M(es), s⟩ -ε→ ⟨Throw a, s⟩"
| CallThrowParams: "⟦ es = map Val vs @ Throw a # es' ⟧ ⟹ extTA,P,t ⊢ ⟨(Val v)∙M(es), s⟩ -ε→ ⟨Throw a, s⟩"
| BlockThrow: "extTA,P,t ⊢ ⟨{V:T=vo; Throw a}, s⟩ -ε→ ⟨Throw a, s⟩"
| SynchronizedThrow1: "extTA,P,t ⊢ ⟨sync(Throw a) e, s⟩ -ε→ ⟨Throw a, s⟩"
| SynchronizedThrow2: "extTA,P,t ⊢ ⟨insync(a) Throw ad, s⟩ -⦃Unlock→a, SyncUnlock a⦄→ ⟨Throw ad, s⟩"
| SeqThrow: "extTA,P,t ⊢ ⟨(Throw a);;e⇩2, s⟩ -ε→ ⟨Throw a, s⟩"
| CondThrow: "extTA,P,t ⊢ ⟨if (Throw a) e⇩1 else e⇩2, s⟩ -ε→ ⟨Throw a, s⟩"
| ThrowThrow: "extTA,P,t ⊢ ⟨throw(Throw a), s⟩ -ε→ ⟨Throw a, s⟩"
inductive_cases red_cases:
"extTA,P,t ⊢ ⟨new C, s⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨newA T⌊e⌉, s⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨Cast T e, s⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨e instanceof T, s⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨e «bop» e', s⟩ -ta→ ⟨e'', s'⟩"
"extTA,P,t ⊢ ⟨Var V, s⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨V:=e, s⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨a⌊i⌉, s⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨a⌊i⌉ := e, s⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨a∙length, s⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨e∙F{D}, s⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨e∙F{D} := e', s⟩ -ta→ ⟨e'', s'⟩"
"extTA,P,t ⊢ ⟨e∙compareAndSwap(D∙F, e', e''), s⟩ -ta→ ⟨e''', s'⟩"
"extTA,P,t ⊢ ⟨e∙M(es), s⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨{V:T=vo; e}, s⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨sync(o') e, s⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨insync(a) e, s⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨e;;e', s⟩ -ta→ ⟨e'', s'⟩"
"extTA,P,t ⊢ ⟨if (b) e1 else e2, s ⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨while (b) e, s ⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨throw e, s ⟩ -ta→ ⟨e', s'⟩"
"extTA,P,t ⊢ ⟨try e catch(C V) e', s⟩ -ta→ ⟨e'', s'⟩"
inductive_cases reds_cases:
"extTA,P,t ⊢ ⟨e # es, s⟩ [-ta→] ⟨es', s'⟩"
abbreviation red' ::
"'addr J_prog ⇒ 'thread_id ⇒ 'addr expr ⇒ ('heap × 'addr locals)
⇒ ('addr, 'thread_id, 'heap) J_thread_action ⇒ 'addr expr ⇒ ('heap × 'addr locals) ⇒ bool"
("_,_ ⊢ ((1⟨_,/_⟩) -_→/ (1⟨_,/_⟩))" [51,0,0,0,0,0,0] 81)
where "red' P ≡ red (extTA2J P) P"
abbreviation reds' ::
"'addr J_prog ⇒ 'thread_id ⇒ 'addr expr list ⇒ ('heap × 'addr locals)
⇒ ('addr, 'thread_id, 'heap) J_thread_action ⇒ 'addr expr list ⇒ ('heap × 'addr locals) ⇒ bool"
("_,_ ⊢ ((1⟨_,/_⟩) [-_→]/ (1⟨_,/_⟩))" [51,0,0,0,0,0,0] 81)
where "reds' P ≡ reds (extTA2J P) P"
subsection‹Some easy lemmas›
lemma [iff]:
"¬ extTA,P,t ⊢ ⟨Val v, s⟩ -ta→ ⟨e', s'⟩"
by(fastforce elim:red.cases)
lemma red_no_val [dest]:
"⟦ extTA,P,t ⊢ ⟨e, s⟩ -tas→ ⟨e', s'⟩; is_val e ⟧ ⟹ False"
by(auto)
lemma [iff]: "¬ extTA,P,t ⊢ ⟨Throw a, s⟩ -ta→ ⟨e', s'⟩"
by(fastforce elim: red_cases)
lemma reds_map_Val_Throw:
"extTA,P,t ⊢ ⟨map Val vs @ Throw a # es, s⟩ [-ta→] ⟨es', s'⟩ ⟷ False"
by(induct vs arbitrary: es')(auto elim!: reds_cases)
lemma reds_preserves_len:
"extTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩ ⟹ length es' = length es"
by(induct es arbitrary: es')(auto elim: reds.cases)
lemma red_lcl_incr: "extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ dom (lcl s) ⊆ dom (lcl s')"
and reds_lcl_incr: "extTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩ ⟹ dom (lcl s) ⊆ dom (lcl s')"
apply(induct rule:red_reds.inducts)
apply(auto simp del: fun_upd_apply split: if_split_asm)
done
lemma red_lcl_add_aux:
"extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ extTA,P,t ⊢ ⟨e, (hp s, l0 ++ lcl s)⟩ -ta→ ⟨e', (hp s', l0 ++ lcl s')⟩"
and reds_lcl_add_aux:
"extTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩ ⟹ extTA,P,t ⊢ ⟨es, (hp s, l0 ++ lcl s)⟩ [-ta→] ⟨es', (hp s', l0 ++ lcl s')⟩"
proof (induct arbitrary: l0 and l0 rule:red_reds.inducts)
case (BlockRed e h x V vo ta e' h' x' T)
note IH = ‹⋀l0. extTA,P,t ⊢ ⟨e,(hp (h, x(V := vo)), l0 ++ lcl (h, x(V := vo)))⟩ -ta→ ⟨e',(hp (h', x'), l0 ++ lcl (h', x'))⟩›[simplified]
have lrew: "⋀x x'. x(V := vo) ++ x'(V := vo) = (x ++ x')(V := vo)"
by(simp add:fun_eq_iff map_add_def)
have lrew1: "⋀X X' X'' vo. (X(V := vo) ++ X')(V := (X ++ X'') V) = X ++ X'(V := X'' V)"
by(simp add: fun_eq_iff map_add_def)
have lrew2: "⋀X X'. (X(V := None) ++ X') V = X' V"
by(simp add: map_add_def)
show ?case
proof(cases vo)
case None
from IH[of "l0(V := vo)"]
show ?thesis
apply(simp del: fun_upd_apply add: lrew)
apply(drule red_reds.BlockRed)
by(simp only: lrew1 None lrew2)
next
case (Some v)
with ‹extTA,P,t ⊢ ⟨e,(h, x(V := vo))⟩ -ta→ ⟨e',(h', x')⟩›
have "x' V ≠ None"
by -(drule red_lcl_incr, auto split: if_split_asm)
with IH[of "l0(V := vo)"]
show ?thesis
apply(clarsimp simp del: fun_upd_apply simp add: lrew)
apply(drule red_reds.BlockRed)
by(simp add: lrew1 Some del: fun_upd_apply)
qed
next
case RedTryFail thus ?case
by(auto intro: red_reds.RedTryFail)
qed(fastforce intro:red_reds.intros simp del: fun_upd_apply)+
lemma red_lcl_add: "extTA,P,t ⊢ ⟨e, (h, l)⟩ -ta→ ⟨e', (h', l')⟩ ⟹ extTA,P,t ⊢ ⟨e, (h, l0 ++ l)⟩ -ta→ ⟨e', (h', l0 ++ l')⟩"
and reds_lcl_add: "extTA,P,t ⊢ ⟨es, (h, l)⟩ [-ta→] ⟨es', (h', l')⟩ ⟹ extTA,P,t ⊢ ⟨es, (h, l0 ++ l)⟩ [-ta→] ⟨es', (h', l0 ++ l')⟩"
by(auto dest:red_lcl_add_aux reds_lcl_add_aux)
lemma reds_no_val [dest]:
"⟦ extTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; is_vals es ⟧ ⟹ False"
apply(induct es arbitrary: s ta es' s')
apply(blast elim: reds.cases)
apply(erule reds.cases)
apply(auto, blast)
done
lemma red_no_Throw [dest!]:
"extTA,P,t ⊢ ⟨Throw a, s⟩ -ta→ ⟨e', s'⟩ ⟹ False"
by(auto elim!: red_cases)
lemma red_lcl_sub:
"⟦ extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; fv e ⊆ W ⟧
⟹ extTA,P,t ⊢ ⟨e, (hp s, (lcl s)|`W)⟩ -ta→ ⟨e', (hp s', (lcl s')|`W)⟩"
and reds_lcl_sub:
"⟦ extTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; fvs es ⊆ W ⟧
⟹ extTA,P,t ⊢ ⟨es, (hp s, (lcl s)|`W)⟩ [-ta→] ⟨es', (hp s', (lcl s')|`W)⟩"
proof(induct arbitrary: W and W rule: red_reds.inducts)
case (RedLAss V v h l W)
have "extTA,P,t ⊢ ⟨V:=Val v,(h, l |` W)⟩ -ε→ ⟨unit,(h, (l |`W)(V ↦ v))⟩"
by(rule red_reds.RedLAss)
with RedLAss show ?case by(simp del: fun_upd_apply)
next
case (BlockRed e h x V vo ta e' h' x' T)
have IH: "⋀W. fv e ⊆ W ⟹ extTA,P,t ⊢ ⟨e,(hp (h, x(V := vo)), lcl (h, x(V := vo)) |` W)⟩ -ta→ ⟨e',(hp (h', x'), lcl (h', x') |` W)⟩" by fact
from ‹fv {V:T=vo; e} ⊆ W› have fve: "fv e ⊆ insert V W" by auto
show ?case
proof(cases "V ∈ W")
case True
with fve have "fv e ⊆ W" by auto
from True IH[OF this] have "extTA,P,t ⊢ ⟨e,(h, (x |` W )(V := vo))⟩ -ta→ ⟨e',(h', x' |` W)⟩" by(simp)
with True have "extTA,P,t ⊢ ⟨{V:T=vo; e},(h, x |` W)⟩ -ta→ ⟨{V:T=x' V; e'},(h', (x' |` W)(V := x V))⟩"
by -(drule red_reds.BlockRed[where T=T], simp)
with True show ?thesis by(simp del: fun_upd_apply)
next
case False
with IH[OF fve] have "extTA,P,t ⊢ ⟨e,(h, (x |` W)(V := vo))⟩ -ta→ ⟨e',(h', x' |` insert V W)⟩" by(simp)
with False have "extTA,P,t ⊢ ⟨{V:T=vo; e},(h, x |` W)⟩ -ta→ ⟨{V:T=x' V; e'},(h', (x' |` W))⟩"
by -(drule red_reds.BlockRed[where T=T],simp)
with False show ?thesis by(simp del: fun_upd_apply)
qed
next
case RedTryFail thus ?case by(auto intro: red_reds.RedTryFail)
qed(fastforce intro: red_reds.intros)+
lemma red_notfree_unchanged: "⟦ extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; V ∉ fv e ⟧ ⟹ lcl s' V = lcl s V"
and reds_notfree_unchanged: "⟦ extTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; V ∉ fvs es ⟧ ⟹ lcl s' V = lcl s V"
apply(induct rule: red_reds.inducts)
apply(fastforce)+
done
lemma red_dom_lcl: "extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ dom (lcl s') ⊆ dom (lcl s) ∪ fv e"
and reds_dom_lcl: "extTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩ ⟹ dom (lcl s') ⊆ dom (lcl s) ∪ fvs es"
proof (induct rule:red_reds.inducts)
case (BlockRed e h x V vo ta e' h' x' T)
thus ?case by(clarsimp)(fastforce split:if_split_asm)
qed auto
lemma red_Suspend_is_call:
"⟦ convert_extTA extNTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; Suspend w ∈ set ⦃ta⦄⇘w⇙ ⟧
⟹ ∃a vs hT Ts Tr D. call e' = ⌊(a, wait, vs)⌋ ∧ typeof_addr (hp s) a = ⌊hT⌋ ∧ P ⊢ class_type_of hT sees wait:Ts→Tr = Native in D"
and reds_Suspend_is_calls:
"⟦ convert_extTA extNTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; Suspend w ∈ set ⦃ta⦄⇘w⇙ ⟧
⟹ ∃a vs hT Ts Tr D. calls es' = ⌊(a, wait, vs)⌋ ∧ typeof_addr (hp s) a = ⌊hT⌋ ∧ P ⊢ class_type_of hT sees wait:Ts→Tr = Native in D"
proof(induct rule: red_reds.inducts)
case RedCallExternal
thus ?case
apply clarsimp
apply(frule red_external_Suspend_StaySame, simp)
apply(drule red_external_Suspend_waitD, fastforce+)
done
qed auto
end
context J_heap begin
lemma red_hext_incr: "extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ hp s ⊴ hp s'"
and reds_hext_incr: "extTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩ ⟹ hp s ⊴ hp s'"
by(induct rule:red_reds.inducts)(auto intro: hext_heap_ops red_external_hext)
lemma red_preserves_tconf: "⟦ extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; P,hp s ⊢ t √t ⟧ ⟹ P,hp s' ⊢ t √t"
by(drule red_hext_incr)(rule tconf_hext_mono)
lemma reds_preserves_tconf: "⟦ extTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; P,hp s ⊢ t √t ⟧ ⟹ P,hp s' ⊢ t √t"
by(drule reds_hext_incr)(rule tconf_hext_mono)
end
subsection ‹Code generation›
context J_heap_base begin
lemma RedCall_code:
"⟦ is_vals es; typeof_addr (hp s) a = ⌊hU⌋; P ⊢ class_type_of hU sees M:Ts→T = ⌊(pns,body)⌋ in D;
size es = size pns; size Ts = size pns ⟧
⟹ extTA,P,t ⊢ ⟨(addr a)∙M(es), s⟩ -ε→ ⟨blocks (this # pns) (Class D # Ts) (Addr a # map the_Val es) body, s⟩"
and RedCallExternal_code:
"⟦ is_vals es; typeof_addr (hp s) a = ⌊hU⌋; P ⊢ class_type_of hU sees M:Ts→T = Native in D;
P,t ⊢ ⟨a∙M(map the_Val es), hp s⟩ -ta→ext ⟨va, h'⟩ ⟧
⟹ extTA,P,t ⊢ ⟨(addr a)∙M(es), s⟩ -extTA ta→ ⟨extRet2J ((addr a)∙M(es)) va, (h', lcl s)⟩"
and RedCallNull_code:
"is_vals es ⟹ extTA,P,t ⊢ ⟨null∙M(es), s⟩ -ε→ ⟨THROW NullPointer, s⟩"
and CallThrowParams_code:
"is_Throws es ⟹ extTA,P,t ⊢ ⟨(Val v)∙M(es), s⟩ -ε→ ⟨hd (dropWhile is_val es), s⟩"
apply(auto simp add: is_vals_conv is_Throws_conv o_def intro: RedCall RedCallExternal RedCallNull simp del: blocks.simps)
apply(subst dropWhile_append2)
apply(auto intro: CallThrowParams)
done
end
lemmas [code_pred_intro] =
J_heap_base.RedNew[folded Predicate_Compile.contains_def] J_heap_base.RedNewFail J_heap_base.NewArrayRed
J_heap_base.RedNewArray[folded Predicate_Compile.contains_def]
J_heap_base.RedNewArrayNegative J_heap_base.RedNewArrayFail
J_heap_base.CastRed J_heap_base.RedCast J_heap_base.RedCastFail J_heap_base.InstanceOfRed
J_heap_base.RedInstanceOf J_heap_base.BinOpRed1 J_heap_base.BinOpRed2 J_heap_base.RedBinOp J_heap_base.RedBinOpFail
J_heap_base.RedVar J_heap_base.LAssRed J_heap_base.RedLAss
J_heap_base.AAccRed1 J_heap_base.AAccRed2 J_heap_base.RedAAccNull
J_heap_base.RedAAccBounds J_heap_base.RedAAcc J_heap_base.AAssRed1 J_heap_base.AAssRed2 J_heap_base.AAssRed3
J_heap_base.RedAAssNull J_heap_base.RedAAssBounds J_heap_base.RedAAssStore J_heap_base.RedAAss J_heap_base.ALengthRed
J_heap_base.RedALength J_heap_base.RedALengthNull J_heap_base.FAccRed J_heap_base.RedFAcc J_heap_base.RedFAccNull
J_heap_base.FAssRed1 J_heap_base.FAssRed2 J_heap_base.RedFAss J_heap_base.RedFAssNull
J_heap_base.CASRed1 J_heap_base.CASRed2 J_heap_base.CASRed3 J_heap_base.CASNull J_heap_base.RedCASSucceed J_heap_base.RedCASFail
J_heap_base.CallObj J_heap_base.CallParams
declare
J_heap_base.RedCall_code[code_pred_intro RedCall_code]
J_heap_base.RedCallExternal_code[code_pred_intro RedCallExternal_code]
J_heap_base.RedCallNull_code[code_pred_intro RedCallNull_code]
lemmas [code_pred_intro] =
J_heap_base.BlockRed J_heap_base.RedBlock J_heap_base.SynchronizedRed1 J_heap_base.SynchronizedNull
J_heap_base.LockSynchronized J_heap_base.SynchronizedRed2 J_heap_base.UnlockSynchronized
J_heap_base.SeqRed J_heap_base.RedSeq J_heap_base.CondRed J_heap_base.RedCondT J_heap_base.RedCondF J_heap_base.RedWhile
J_heap_base.ThrowRed
declare
J_heap_base.RedThrowNull[code_pred_intro RedThrowNull']
lemmas [code_pred_intro] =
J_heap_base.TryRed J_heap_base.RedTry J_heap_base.RedTryCatch
J_heap_base.RedTryFail J_heap_base.ListRed1 J_heap_base.ListRed2
J_heap_base.NewArrayThrow J_heap_base.CastThrow J_heap_base.InstanceOfThrow J_heap_base.BinOpThrow1 J_heap_base.BinOpThrow2
J_heap_base.LAssThrow J_heap_base.AAccThrow1 J_heap_base.AAccThrow2 J_heap_base.AAssThrow1 J_heap_base.AAssThrow2
J_heap_base.AAssThrow3 J_heap_base.ALengthThrow J_heap_base.FAccThrow J_heap_base.FAssThrow1 J_heap_base.FAssThrow2
J_heap_base.CASThrow J_heap_base.CASThrow2 J_heap_base.CASThrow3
J_heap_base.CallThrowObj
declare
J_heap_base.CallThrowParams_code[code_pred_intro CallThrowParams_code]
lemmas [code_pred_intro] =
J_heap_base.BlockThrow J_heap_base.SynchronizedThrow1 J_heap_base.SynchronizedThrow2 J_heap_base.SeqThrow
J_heap_base.CondThrow
declare
J_heap_base.ThrowThrow[code_pred_intro ThrowThrow']
code_pred
(modes:
J_heap_base.red: i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ (i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ (i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ o ⇒ bool
and
J_heap_base.reds: i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ (i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ (i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ o ⇒ bool)
[detect_switches, skip_proof]
J_heap_base.red
proof -
case red
from red.prems show thesis
proof(cases rule: J_heap_base.red.cases[consumes 1, case_names
RedNew RedNewFail NewArrayRed RedNewArray RedNewArrayNegative RedNewArrayFail CastRed RedCast RedCastFail InstanceOfRed
RedInstanceOf BinOpRed1 BinOpRed2 RedBinOp RedBinOpFail RedVar LAssRed RedLAss
AAccRed1 AAccRed2 RedAAccNull RedAAccBounds RedAAcc
AAssRed1 AAssRed2 AAssRed3 RedAAssNull RedAAssBounds RedAAssStore RedAAss ALengthRed RedALength RedALengthNull FAccRed
RedFAcc RedFAccNull FAssRed1 FAssRed2 RedFAss RedFAssNull CASRed1 CASRed2 CASRed3 RedCASNull RedCASSucceed RedCASFail
CallObj CallParams RedCall RedCallExternal RedCallNull
BlockRed RedBlock SynchronizedRed1 SynchronizedNull LockSynchronized SynchronizedRed2 UnlockSynchronized SeqRed
RedSeq CondRed RedCondT RedCondF RedWhile ThrowRed RedThrowNull TryRed RedTry RedTryCatch RedTryFail
NewArrayThrow CastThrow InstanceOfThrow BinOpThrow1 BinOpThrow2 LAssThrow AAccThrow1 AAccThrow2 AAssThrow1 AAssThrow2
AAssThrow3 ALengthThrow FAccThrow FAssThrow1 FAssThrow2 CASThrow CASThrow2 CASThrow3
CallThrowObj CallThrowParams BlockThrow SynchronizedThrow1
SynchronizedThrow2 SeqThrow CondThrow ThrowThrow])
case (RedCall s a U M Ts T pns body D vs)
with red.RedCall_code[OF refl refl refl refl refl refl refl refl refl refl refl, of a M "map Val vs" s pns D Ts body U T]
show ?thesis by(simp add: o_def)
next
case (RedCallExternal s a U M Ts T D vs ta va h' ta' e' s')
with red.RedCallExternal_code[OF refl refl refl refl refl refl refl refl refl refl refl, of a M "map Val vs" s ta va h' U Ts T D]
show ?thesis by(simp add: o_def)
next
case (RedCallNull M vs s)
with red.RedCallNull_code[OF refl refl refl refl refl refl refl refl refl refl refl, of M "map Val vs" s]
show ?thesis by(simp add: o_def)
next
case (CallThrowParams es vs a es' v M s)
with red.CallThrowParams_code[OF refl refl refl refl refl refl refl refl refl refl refl, of v M "map Val vs @ Throw a # es'" s]
show ?thesis
apply(auto simp add: is_Throws_conv)
apply(erule meta_impE)
apply(subst dropWhile_append2)
apply auto
done
next
case RedThrowNull thus ?thesis
by-(erule (4) red.RedThrowNull'[OF refl refl refl refl refl refl refl refl refl refl refl])
next
case ThrowThrow thus ?thesis
by-(erule (4) red.ThrowThrow'[OF refl refl refl refl refl refl refl refl refl refl refl])
qed(assumption|erule (4) red.that[unfolded Predicate_Compile.contains_def, OF refl refl refl refl refl refl refl refl refl refl refl])+
next
case reds
from reds.prems show thesis
by(rule J_heap_base.reds.cases)(assumption|erule (4) reds.that[OF refl refl refl refl refl refl refl refl refl refl refl])+
qed
end
Theory WellType
section ‹Well-typedness of Jinja expressions›
theory WellType
imports
Expr
State
"../Common/ExternalCallWF"
"../Common/WellForm"
"../Common/SemiType"
begin
declare Listn.lesub_list_impl_same_size[simp del]
declare listE_length [simp del]
type_synonym
env = "vname ⇀ ty"
inductive
WT :: "(ty ⇒ ty ⇒ ty ⇒ bool) ⇒ 'addr J_prog ⇒ env ⇒ 'addr expr ⇒ ty ⇒ bool" ("_,_,_ ⊢ _ :: _" [51,51,51,51]50)
and WTs :: "(ty ⇒ ty ⇒ ty ⇒ bool) ⇒ 'addr J_prog ⇒ env ⇒ 'addr expr list ⇒ ty list ⇒ bool"
("_,_,_ ⊢ _ [::] _" [51,51,51,51]50)
for is_lub :: "ty ⇒ ty ⇒ ty ⇒ bool" ("⊢ lub'((_,/ _)') = _" [51,51,51] 50)
and P :: "'addr J_prog"
where
WTNew:
"is_class P C ⟹
is_lub,P,E ⊢ new C :: Class C"
| WTNewArray:
"⟦ is_lub,P,E ⊢ e :: Integer; is_type P (T⌊⌉) ⟧ ⟹
is_lub,P,E ⊢ newA T⌊e⌉ :: T⌊⌉"
| WTCast:
"⟦ is_lub,P,E ⊢ e :: T; P ⊢ U ≤ T ∨ P ⊢ T ≤ U; is_type P U ⟧
⟹ is_lub,P,E ⊢ Cast U e :: U"
| WTInstanceOf:
"⟦ is_lub,P,E ⊢ e :: T; P ⊢ U ≤ T ∨ P ⊢ T ≤ U; is_type P U; is_refT U ⟧
⟹ is_lub,P,E ⊢ e instanceof U :: Boolean"
| WTVal:
"typeof v = Some T ⟹
is_lub,P,E ⊢ Val v :: T"
| WTVar:
"E V = Some T ⟹
is_lub,P,E ⊢ Var V :: T"
| WTBinOp:
"⟦ is_lub,P,E ⊢ e1 :: T1; is_lub,P,E ⊢ e2 :: T2; P ⊢ T1«bop»T2 :: T ⟧
⟹ is_lub,P,E ⊢ e1«bop»e2 :: T"
| WTLAss:
"⟦ E V = Some T; is_lub,P,E ⊢ e :: T'; P ⊢ T' ≤ T; V ≠ this ⟧
⟹ is_lub,P,E ⊢ V:=e :: Void"
| WTAAcc:
"⟦ is_lub,P,E ⊢ a :: T⌊⌉; is_lub,P,E ⊢ i :: Integer ⟧
⟹ is_lub,P,E ⊢ a⌊i⌉ :: T"
| WTAAss:
"⟦ is_lub,P,E ⊢ a :: T⌊⌉; is_lub,P,E ⊢ i :: Integer; is_lub,P,E ⊢ e :: T'; P ⊢ T' ≤ T ⟧
⟹ is_lub,P,E ⊢ a⌊i⌉ := e :: Void"
| WTALength:
"is_lub,P,E ⊢ a :: T⌊⌉ ⟹ is_lub,P,E ⊢ a∙length :: Integer"
| WTFAcc:
"⟦ is_lub,P,E ⊢ e :: U; class_type_of' U = ⌊C⌋; P ⊢ C sees F:T (fm) in D ⟧
⟹ is_lub,P,E ⊢ e∙F{D} :: T"
| WTFAss:
"⟦ is_lub,P,E ⊢ e⇩1 :: U; class_type_of' U = ⌊C⌋; P ⊢ C sees F:T (fm) in D; is_lub,P,E ⊢ e⇩2 :: T'; P ⊢ T' ≤ T ⟧
⟹ is_lub,P,E ⊢ e⇩1∙F{D}:=e⇩2 :: Void"
| WTCAS:
"⟦ is_lub,P,E ⊢ e1 :: U; class_type_of' U = ⌊C⌋; P ⊢ C sees F:T (fm) in D; volatile fm;
is_lub,P,E ⊢ e2 :: T'; P ⊢ T' ≤ T; is_lub,P,E ⊢ e3 :: T''; P ⊢ T'' ≤ T ⟧
⟹ is_lub,P,E ⊢ e1∙compareAndSwap(D∙F, e2, e3) :: Boolean"
| WTCall:
"⟦ is_lub,P,E ⊢ e :: U; class_type_of' U = ⌊C⌋; P ⊢ C sees M:Ts → T = meth in D;
is_lub,P,E ⊢ es [::] Ts'; P ⊢ Ts' [≤] Ts ⟧
⟹ is_lub,P,E ⊢ e∙M(es) :: T"
| WTBlock:
"⟦ is_type P T; is_lub,P,E(V ↦ T) ⊢ e :: T'; case vo of None ⇒ True | ⌊v⌋ ⇒ ∃T'. typeof v = ⌊T'⌋ ∧ P ⊢ T' ≤ T ⟧
⟹ is_lub,P,E ⊢ {V:T=vo; e} :: T'"
| WTSynchronized:
"⟦ is_lub,P,E ⊢ o' :: T; is_refT T; T ≠ NT; is_lub,P,E ⊢ e :: T' ⟧
⟹ is_lub,P,E ⊢ sync(o') e :: T'"
| WTSeq:
"⟦ is_lub,P,E ⊢ e⇩1::T⇩1; is_lub,P,E ⊢ e⇩2::T⇩2 ⟧
⟹ is_lub,P,E ⊢ e⇩1;;e⇩2 :: T⇩2"
| WTCond:
"⟦ is_lub,P,E ⊢ e :: Boolean; is_lub,P,E ⊢ e⇩1::T⇩1; is_lub,P,E ⊢ e⇩2::T⇩2; ⊢ lub(T⇩1, T⇩2) = T ⟧
⟹ is_lub,P,E ⊢ if (e) e⇩1 else e⇩2 :: T"
| WTWhile:
"⟦ is_lub,P,E ⊢ e :: Boolean; is_lub,P,E ⊢ c::T ⟧
⟹ is_lub,P,E ⊢ while (e) c :: Void"
| WTThrow:
"⟦ is_lub,P,E ⊢ e :: Class C; P ⊢ C ≼⇧* Throwable ⟧ ⟹
is_lub,P,E ⊢ throw e :: Void"
| WTTry:
"⟦ is_lub,P,E ⊢ e⇩1 :: T; is_lub,P,E(V ↦ Class C) ⊢ e⇩2 :: T; P ⊢ C ≼⇧* Throwable ⟧
⟹ is_lub,P,E ⊢ try e⇩1 catch(C V) e⇩2 :: T"
| WTNil: "is_lub,P,E ⊢ [] [::] []"
| WTCons: "⟦ is_lub,P,E ⊢ e :: T; is_lub,P,E ⊢ es [::] Ts ⟧ ⟹ is_lub,P,E ⊢ e#es [::] T#Ts"
abbreviation WT' :: "'addr J_prog ⇒ env ⇒ 'addr expr ⇒ ty ⇒ bool" ("_,_ ⊢ _ :: _" [51,51,51] 50)
where "WT' P ≡ WT (TypeRel.is_lub P) P"
abbreviation WTs' :: "'addr J_prog ⇒ env ⇒ 'addr expr list ⇒ ty list ⇒ bool" ("_,_ ⊢ _ [::] _" [51,51,51] 50)
where "WTs' P ≡ WTs (TypeRel.is_lub P) P"
declare WT_WTs.intros[intro!]
inductive_simps WTs_iffs [iff]:
"is_lub',P,E ⊢ [] [::] Ts"
"is_lub',P,E ⊢ e#es [::] T#Ts"
"is_lub',P,E ⊢ e#es [::] Ts"
lemma WTs_conv_list_all2:
fixes is_lub
shows "is_lub,P,E ⊢ es [::] Ts = list_all2 (WT is_lub P E) es Ts"
by(induct es arbitrary: Ts)(auto simp add: list_all2_Cons1 elim: WTs.cases)
lemma WTs_append [iff]: "⋀is_lub Ts. (is_lub,P,E ⊢ es⇩1 @ es⇩2 [::] Ts) =
(∃Ts⇩1 Ts⇩2. Ts = Ts⇩1 @ Ts⇩2 ∧ is_lub,P,E ⊢ es⇩1 [::] Ts⇩1 ∧ is_lub,P,E ⊢ es⇩2[::]Ts⇩2)"
by(auto simp add: WTs_conv_list_all2 list_all2_append1 dest: list_all2_lengthD[symmetric])
inductive_simps WT_iffs [iff]:
"is_lub',P,E ⊢ Val v :: T"
"is_lub',P,E ⊢ Var V :: T"
"is_lub',P,E ⊢ e⇩1;;e⇩2 :: T⇩2"
"is_lub',P,E ⊢ {V:T=vo; e} :: T'"
inductive_cases WT_elim_cases[elim!]:
"is_lub',P,E ⊢ V :=e :: T"
"is_lub',P,E ⊢ sync(o') e :: T"
"is_lub',P,E ⊢ if (e) e⇩1 else e⇩2 :: T"
"is_lub',P,E ⊢ while (e) c :: T"
"is_lub',P,E ⊢ throw e :: T"
"is_lub',P,E ⊢ try e⇩1 catch(C V) e⇩2 :: T"
"is_lub',P,E ⊢ Cast D e :: T"
"is_lub',P,E ⊢ e instanceof U :: T"
"is_lub',P,E ⊢ a∙F{D} :: T"
"is_lub',P,E ⊢ a∙F{D} := v :: T"
"is_lub',P,E ⊢ e∙compareAndSwap(D∙F, e', e'') :: T"
"is_lub',P,E ⊢ e⇩1 «bop» e⇩2 :: T"
"is_lub',P,E ⊢ new C :: T"
"is_lub',P,E ⊢ newA T⌊e⌉ :: T'"
"is_lub',P,E ⊢ a⌊i⌉ := e :: T"
"is_lub',P,E ⊢ a⌊i⌉ :: T"
"is_lub',P,E ⊢ a∙length :: T"
"is_lub',P,E ⊢ e∙M(ps) :: T"
"is_lub',P,E ⊢ sync(o') e :: T"
"is_lub',P,E ⊢ insync(a) e :: T"
lemma fixes is_lub :: "ty ⇒ ty ⇒ ty ⇒ bool" ("⊢ lub'((_,/ _)') = _" [51,51,51] 50)
assumes is_lub_unique: "⋀T1 T2 T3 T4. ⟦ ⊢ lub(T1, T2) = T3; ⊢ lub(T1, T2) = T4 ⟧ ⟹ T3 = T4"
shows WT_unique: "⟦ is_lub,P,E ⊢ e :: T; is_lub,P,E ⊢ e :: T' ⟧ ⟹ T = T'"
and WTs_unique: "⟦ is_lub,P,E ⊢ es [::] Ts; is_lub,P,E ⊢ es [::] Ts' ⟧ ⟹ Ts = Ts'"
apply(induct arbitrary: T' and Ts' rule: WT_WTs.inducts)
apply blast
apply blast
apply blast
apply blast
apply fastforce
apply fastforce
apply(fastforce dest: WT_binop_fun)
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply(fastforce dest: sees_field_fun)
apply(fastforce dest: sees_field_fun)
apply blast
apply(fastforce dest: sees_method_fun)
apply fastforce
apply fastforce
apply fastforce
apply(blast dest: is_lub_unique)
apply fastforce
apply fastforce
apply blast
apply fastforce
apply fastforce
done
lemma fixes is_lub
shows wt_env_mono: "is_lub,P,E ⊢ e :: T ⟹ (⋀E'. E ⊆⇩m E' ⟹ is_lub,P,E' ⊢ e :: T)"
and wts_env_mono: "is_lub,P,E ⊢ es [::] Ts ⟹ (⋀E'. E ⊆⇩m E' ⟹ is_lub,P,E' ⊢ es [::] Ts)"
apply(induct rule: WT_WTs.inducts)
apply(simp add: WTNew)
apply(simp add: WTNewArray)
apply(fastforce simp: WTCast)
apply(fastforce simp: WTInstanceOf)
apply(fastforce simp: WTVal)
apply(simp add: WTVar map_le_def dom_def)
apply(fastforce simp: WTBinOp)
apply(force simp:map_le_def)
apply(simp add: WTAAcc)
apply(simp add: WTAAss, fastforce)
apply(simp add: WTALength, fastforce)
apply(fastforce simp: WTFAcc)
apply(fastforce simp: WTFAss del:WT_WTs.intros WT_elim_cases)
apply blast
apply(fastforce)
apply(fastforce simp: map_le_def WTBlock)
apply(fastforce simp: WTSynchronized)
apply(fastforce simp: WTSeq)
apply(fastforce simp: WTCond)
apply(fastforce simp: WTWhile)
apply(fastforce simp: WTThrow)
apply(fastforce simp: WTTry map_le_def dom_def)
apply(fastforce)+
done
lemma fixes is_lub
shows WT_fv: "is_lub,P,E ⊢ e :: T ⟹ fv e ⊆ dom E"
and WT_fvs: "is_lub,P,E ⊢ es [::] Ts ⟹ fvs es ⊆ dom E"
apply(induct rule:WT_WTs.inducts)
apply(simp_all del: fun_upd_apply)
apply fast+
done
lemma fixes is_lub
shows WT_expr_locks: "is_lub,P,E ⊢ e :: T ⟹ expr_locks e = (λad. 0)"
and WTs_expr_lockss: "is_lub,P,E ⊢ es [::] Ts ⟹ expr_lockss es = (λad. 0)"
by(induct rule: WT_WTs.inducts)(auto)
lemma
fixes is_lub :: "ty ⇒ ty ⇒ ty ⇒ bool" ("⊢ lub'((_,/ _)') = _" [51,51,51] 50)
assumes is_lub_is_type: "⋀T1 T2 T3. ⟦ ⊢ lub(T1, T2) = T3; is_type P T1; is_type P T2 ⟧ ⟹ is_type P T3"
and wf: "wf_prog wf_md P"
shows WT_is_type: "⟦ is_lub,P,E ⊢ e :: T; ran E ⊆ types P ⟧ ⟹ is_type P T"
and WTs_is_type: "⟦ is_lub,P,E ⊢ es [::] Ts; ran E ⊆ types P ⟧ ⟹ set Ts ⊆ types P"
apply(induct rule: WT_WTs.inducts)
apply simp
apply simp
apply simp
apply simp
apply (simp add:typeof_lit_is_type)
apply (fastforce intro:nth_mem simp add: ran_def)
apply(simp add: WT_binop_is_type)
apply(simp)
apply(simp del: is_type_array add: is_type_ArrayD)
apply(simp)
apply(simp)
apply(simp add:sees_field_is_type[OF _ wf])
apply(simp)
apply simp
apply(fastforce dest: sees_wf_mdecl[OF wf] simp:wf_mdecl_def)
apply(fastforce simp add: ran_def split: if_split_asm)
apply(simp add: is_class_Object[OF wf])
apply(simp)
apply(simp)
apply(fastforce intro: is_lub_is_type)
apply(simp)
apply(simp)
apply simp
apply simp
apply simp
done
lemma
fixes is_lub1 :: "ty ⇒ ty ⇒ ty ⇒ bool" ("⊢1 lub'((_,/ _)') = _" [51,51,51] 50)
and is_lub2 :: "ty ⇒ ty ⇒ ty ⇒ bool" ("⊢2 lub'((_,/ _)') = _" [51,51,51] 50)
assumes wf: "wf_prog wf_md P"
and is_lub1_into_is_lub2: "⋀T1 T2 T3. ⟦ ⊢1 lub(T1, T2) = T3; is_type P T1; is_type P T2 ⟧ ⟹ ⊢2 lub(T1, T2) = T3"
and is_lub2_is_type: "⋀T1 T2 T3. ⟦ ⊢2 lub(T1, T2) = T3; is_type P T1; is_type P T2 ⟧ ⟹ is_type P T3"
shows WT_change_is_lub: "⟦ is_lub1,P,E ⊢ e :: T; ran E ⊆ types P ⟧ ⟹ is_lub2,P,E ⊢ e :: T"
and WTs_change_is_lub: "⟦ is_lub1,P,E ⊢ es [::] Ts; ran E ⊆ types P ⟧ ⟹ is_lub2,P,E ⊢ es [::] Ts"
proof(induct rule: WT_WTs.inducts)
case (WTBlock U E V e' T vo)
from ‹is_type P U› ‹ran E ⊆ types P›
have "ran (E(V ↦ U)) ⊆ types P" by(auto simp add: ran_def)
hence "is_lub2,P,E(V ↦ U) ⊢ e' :: T" by(rule WTBlock)
with ‹is_type P U› show ?case
using ‹case vo of None ⇒ True | ⌊v⌋ ⇒ ∃T'. typeof v = ⌊T'⌋ ∧ P ⊢ T' ≤ U› by auto
next
case (WTCond E e e1 T1 e2 T2 T)
from ‹ran E ⊆ types P› have "is_lub2,P,E ⊢ e :: Boolean" "is_lub2,P,E ⊢ e1 :: T1" "is_lub2,P,E ⊢ e2 :: T2"
by(rule WTCond)+
moreover from is_lub2_is_type wf ‹is_lub2,P,E ⊢ e1 :: T1› ‹ran E ⊆ types P›
have "is_type P T1" by(rule WT_is_type)
from is_lub2_is_type wf ‹is_lub2,P,E ⊢ e2 :: T2› ‹ran E ⊆ types P›
have "is_type P T2" by(rule WT_is_type)
with ‹⊢1 lub(T1, T2) = T› ‹is_type P T1›
have "⊢2 lub(T1, T2) = T" by(rule is_lub1_into_is_lub2)
ultimately show ?case ..
next
case (WTTry E e1 T V C e2)
from ‹ran E ⊆ types P› have "is_lub2,P,E ⊢ e1 :: T" by(rule WTTry)
moreover from ‹P ⊢ C ≼⇧* Throwable› have "is_class P C"
by(rule is_class_sub_Throwable[OF wf])
with ‹ran E ⊆ types P› have "ran (E(V ↦ Class C)) ⊆ types P"
by(auto simp add: ran_def)
hence "is_lub2,P,E(V ↦ Class C) ⊢ e2 :: T" by(rule WTTry)
ultimately show ?case using ‹P ⊢ C ≼⇧* Throwable› ..
qed auto
subsection ‹Code generator setup›
lemma WTBlock_code:
"⋀is_lub. ⟦ is_type P T; is_lub,P,E(V ↦ T) ⊢ e :: T';
case vo of None ⇒ True | ⌊v⌋ ⇒ case typeof v of None ⇒ False | Some T' ⇒ P ⊢ T' ≤ T ⟧
⟹ is_lub,P,E ⊢ {V:T=vo; e} :: T'"
by(auto)
lemmas [code_pred_intro] =
WTNew WTNewArray WTCast WTInstanceOf WTVal WTVar WTBinOp WTLAss WTAAcc WTAAss WTALength WTFAcc WTFAss WTCAS WTCall
declare
WTBlock_code [code_pred_intro WTBlock']
lemmas [code_pred_intro] =
WTSynchronized WTSeq WTCond WTWhile WTThrow WTTry
WTNil WTCons
code_pred
(modes:
(i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool,
(i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ i ⇒ bool)
[detect_switches, skip_proof]
WT
proof -
case WT
from WT.prems show thesis
proof cases
case (WTBlock T V e vo)
thus thesis using WT.WTBlock'[OF refl refl refl, of V T vo e] by(auto)
qed(assumption|erule WT.that[OF refl refl refl]|rule refl)+
next
case WTs
from WTs.prems WTs.that show thesis by cases blast+
qed
inductive is_lub_sup :: "'m prog ⇒ ty ⇒ ty ⇒ ty ⇒ bool"
for P T1 T2 T3
where
"sup P T1 T2 = OK T3 ⟹ is_lub_sup P T1 T2 T3"
code_pred
(modes: i ⇒ i ⇒ i ⇒ o ⇒ bool, i ⇒ i ⇒ i ⇒ i ⇒ bool)
is_lub_sup
.
definition WT_code :: "'addr J_prog ⇒ env ⇒ 'addr expr ⇒ ty ⇒ bool" ("_,_ ⊢ _ ::'' _" [51,51,51] 50)
where "WT_code P ≡ WT (is_lub_sup P) P"
definition WTs_code :: "'addr J_prog ⇒ env ⇒ 'addr expr list ⇒ ty list ⇒ bool" ("_,_ ⊢ _ [::''] _" [51,51,51] 50)
where "WTs_code P ≡ WTs (is_lub_sup P) P"
lemma assumes wf: "wf_prog wf_md P"
shows WT_code_into_WT:
"⟦ P,E ⊢ e ::' T; ran E ⊆ types P ⟧ ⟹ P,E ⊢ e :: T"
and WTs_code_into_WTs:
"⟦ P,E ⊢ es [::'] Ts; ran E ⊆ types P ⟧ ⟹ P,E ⊢ es [::] Ts"
proof -
assume ran: "ran E ⊆ types P"
{ assume wt: "P,E ⊢ e ::' T"
show "P,E ⊢ e :: T"
by(rule WT_change_is_lub[OF wf _ _ wt[unfolded WT_code_def] ran])(blast elim!: is_lub_sup.cases intro: sup_is_lubI[OF wf] is_lub_is_type[OF wf])+ }
{ assume wts: "P,E ⊢ es [::'] Ts"
show "P,E ⊢ es [::] Ts"
by(rule WTs_change_is_lub[OF wf _ _ wts[unfolded WTs_code_def] ran])(blast elim!: is_lub_sup.cases intro: sup_is_lubI[OF wf] is_lub_is_type[OF wf])+ }
qed
lemma assumes wf: "wf_prog wf_md P"
shows WT_into_WT_code:
"⟦ P,E ⊢ e :: T; ran E ⊆ types P ⟧ ⟹ P,E ⊢ e ::' T"
and WT_into_WTs_code_OK:
"⟦ P,E ⊢ es [::] Ts; ran E ⊆ types P ⟧ ⟹ P,E ⊢ es [::'] Ts"
proof -
assume ran: "ran E ⊆ types P"
{ assume wt: "P,E ⊢ e :: T"
show "P,E ⊢ e ::' T" unfolding WT_code_def
by(rule WT_change_is_lub[OF wf _ _ wt ran])(blast intro!: is_lub_sup.intros intro: is_lub_subD[OF wf] sup_is_type[OF wf] elim!: is_lub_sup.cases)+ }
{ assume wts: "P,E ⊢ es [::] Ts"
show "P,E ⊢ es [::'] Ts" unfolding WTs_code_def
by(rule WTs_change_is_lub[OF wf _ _ wts ran])(blast intro!: is_lub_sup.intros intro: is_lub_subD[OF wf] sup_is_type[OF wf] elim!: is_lub_sup.cases)+ }
qed
theorem WT_eq_WT_code:
assumes "wf_prog wf_md P"
and "ran E ⊆ types P"
shows "P,E ⊢ e :: T ⟷ P,E ⊢ e ::' T"
using assms by(blast intro: WT_code_into_WT WT_into_WT_code)
code_pred
(modes: i ⇒ i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ i ⇒ o ⇒ bool)
[inductify]
WT_code
.
code_pred
(modes: i ⇒ i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ i ⇒ o ⇒ bool)
[inductify]
WTs_code
.
end
Theory DefAss
section ‹Definite assignment›
theory DefAss
imports
Expr
begin
subsection "Hypersets"
type_synonym 'a hyperset = "'a set option"
definition hyperUn :: "'a hyperset ⇒ 'a hyperset ⇒ 'a hyperset" (infixl "⊔" 65)
where
"A ⊔ B ≡ case A of None ⇒ None
| ⌊A⌋ ⇒ (case B of None ⇒ None | ⌊B⌋ ⇒ ⌊A ∪ B⌋)"
definition hyperInt :: "'a hyperset ⇒ 'a hyperset ⇒ 'a hyperset" (infixl "⊓" 70)
where
"A ⊓ B ≡ case A of None ⇒ B
| ⌊A⌋ ⇒ (case B of None ⇒ ⌊A⌋ | ⌊B⌋ ⇒ ⌊A ∩ B⌋)"
definition hyperDiff1 :: "'a hyperset ⇒ 'a ⇒ 'a hyperset" (infixl "⊖" 65)
where
"A ⊖ a ≡ case A of None ⇒ None | ⌊A⌋ ⇒ ⌊A - {a}⌋"
definition hyper_isin :: "'a ⇒ 'a hyperset ⇒ bool" (infix "∈∈" 50)
where
"a ∈∈ A ≡ case A of None ⇒ True | ⌊A⌋ ⇒ a ∈ A"
definition hyper_subset :: "'a hyperset ⇒ 'a hyperset ⇒ bool" (infix "⊑" 50)
where
"A ⊑ B ≡ case B of None ⇒ True
| ⌊B⌋ ⇒ (case A of None ⇒ False | ⌊A⌋ ⇒ A ⊆ B)"
lemmas hyperset_defs =
hyperUn_def hyperInt_def hyperDiff1_def hyper_isin_def hyper_subset_def
lemma [simp]: "⌊{}⌋ ⊔ A = A ∧ A ⊔ ⌊{}⌋ = A"
by(simp add:hyperset_defs)
lemma [simp]: "⌊A⌋ ⊔ ⌊B⌋ = ⌊A ∪ B⌋ ∧ ⌊A⌋ ⊖ a = ⌊A - {a}⌋"
by(simp add:hyperset_defs)
lemma [simp]: "None ⊔ A = None ∧ A ⊔ None = None"
by(simp add:hyperset_defs)
lemma [simp]: "a ∈∈ None ∧ None ⊖ a = None"
by(simp add:hyperset_defs)
lemma hyperUn_assoc: "(A ⊔ B) ⊔ C = A ⊔ (B ⊔ C)"
by(simp add:hyperset_defs Un_assoc)
lemma hyper_insert_comm: "A ⊔ ⌊{a}⌋ = ⌊{a}⌋ ⊔ A ∧ A ⊔ (⌊{a}⌋ ⊔ B) = ⌊{a}⌋ ⊔ (A ⊔ B)"
by(simp add:hyperset_defs)
lemma sqSub_mem_lem [elim]: "⟦ A ⊑ A'; a ∈∈ A ⟧ ⟹ a ∈∈ A'"
by(auto simp add: hyperset_defs)
lemma [iff]: "A ⊑ None"
by(auto simp add: hyperset_defs)
lemma [simp]: "A ⊑ A"
by(auto simp add: hyperset_defs)
lemma [iff]: "⌊A⌋ ⊑ ⌊B⌋ ⟷ A ⊆ B"
by(auto simp add: hyperset_defs)
lemma sqUn_lem2: "A ⊑ A' ⟹ B ⊔ A ⊑ B ⊔ A'"
by(simp add:hyperset_defs) blast
lemma sqSub_trans [trans, intro]: "⟦ A ⊑ B; B ⊑ C ⟧ ⟹ A ⊑ C"
by(auto simp add: hyperset_defs)
lemma hyperUn_comm: "A ⊔ B = B ⊔ A"
by(auto simp add: hyperset_defs)
lemma hyperUn_leftComm: "A ⊔ (B ⊔ C) = B ⊔ (A ⊔ C)"
by(auto simp add: hyperset_defs)
lemmas hyperUn_ac = hyperUn_comm hyperUn_leftComm hyperUn_assoc
lemma [simp]: "⌊{}⌋ ⊔ B = B"
by(auto)
lemma [simp]: "⌊{}⌋ ⊑ A"
by(auto simp add: hyperset_defs)
lemma sqInt_lem: "A ⊑ A' ⟹ A ⊓ B ⊑ A' ⊓ B"
by(auto simp add: hyperset_defs)
subsection "Definite assignment"
primrec 𝒜 :: "('a,'b,'addr) exp ⇒ 'a hyperset"
and 𝒜s :: "('a,'b,'addr) exp list ⇒ 'a hyperset"
where
"𝒜 (new C) = ⌊{}⌋"
| "𝒜 (newA T⌊e⌉) = 𝒜 e"
| "𝒜 (Cast C e) = 𝒜 e"
| "𝒜 (e instanceof T) = 𝒜 e"
| "𝒜 (Val v) = ⌊{}⌋"
| "𝒜 (e⇩1 «bop» e⇩2) = 𝒜 e⇩1 ⊔ 𝒜 e⇩2"
| "𝒜 (Var V) = ⌊{}⌋"
| "𝒜 (LAss V e) = ⌊{V}⌋ ⊔ 𝒜 e"
| "𝒜 (a⌊i⌉) = 𝒜 a ⊔ 𝒜 i"
| "𝒜 (a⌊i⌉ := e) = 𝒜 a ⊔ 𝒜 i ⊔ 𝒜 e"
| "𝒜 (a∙length) = 𝒜 a"
| "𝒜 (e∙F{D}) = 𝒜 e"
| "𝒜 (e⇩1∙F{D}:=e⇩2) = 𝒜 e⇩1 ⊔ 𝒜 e⇩2"
| "𝒜 (e1∙compareAndSwap(D∙F, e2, e3)) = 𝒜 e1 ⊔ 𝒜 e2 ⊔ 𝒜 e3"
| "𝒜 (e∙M(es)) = 𝒜 e ⊔ 𝒜s es"
| "𝒜 ({V:T=vo; e}) = 𝒜 e ⊖ V"
| "𝒜 (sync⇘V⇙ (o') e) = 𝒜 o' ⊔ 𝒜 e"
| "𝒜 (insync⇘V⇙ (a) e) = 𝒜 e"
| "𝒜 (e⇩1;;e⇩2) = 𝒜 e⇩1 ⊔ 𝒜 e⇩2"
| "𝒜 (if (e) e⇩1 else e⇩2) = 𝒜 e ⊔ (𝒜 e⇩1 ⊓ 𝒜 e⇩2)"
| "𝒜 (while (b) e) = 𝒜 b"
| "𝒜 (throw e) = None"
| "𝒜 (try e⇩1 catch(C V) e⇩2) = 𝒜 e⇩1 ⊓ (𝒜 e⇩2 ⊖ V)"
| "𝒜s ([]) = ⌊{}⌋"
| "𝒜s (e#es) = 𝒜 e ⊔ 𝒜s es"
primrec 𝒟 :: "('a,'b,'addr) exp ⇒ 'a hyperset ⇒ bool"
and 𝒟s :: "('a,'b,'addr) exp list ⇒ 'a hyperset ⇒ bool"
where
"𝒟 (new C) A = True"
| "𝒟 (newA T⌊e⌉) A = 𝒟 e A"
| "𝒟 (Cast C e) A = 𝒟 e A"
| "𝒟 (e instanceof T) = 𝒟 e"
| "𝒟 (Val v) A = True"
| "𝒟 (e⇩1 «bop» e⇩2) A = (𝒟 e⇩1 A ∧ 𝒟 e⇩2 (A ⊔ 𝒜 e⇩1))"
| "𝒟 (Var V) A = (V ∈∈ A)"
| "𝒟 (LAss V e) A = 𝒟 e A"
| "𝒟 (a⌊i⌉) A = (𝒟 a A ∧ 𝒟 i (A ⊔ 𝒜 a))"
| "𝒟 (a⌊i⌉ := e) A = (𝒟 a A ∧ 𝒟 i (A ⊔ 𝒜 a) ∧ 𝒟 e (A ⊔ 𝒜 a ⊔ 𝒜 i))"
| "𝒟 (a∙length) A = 𝒟 a A"
| "𝒟 (e∙F{D}) A = 𝒟 e A"
| "𝒟 (e⇩1∙F{D}:=e⇩2) A = (𝒟 e⇩1 A ∧ 𝒟 e⇩2 (A ⊔ 𝒜 e⇩1))"
| "𝒟 (e1∙compareAndSwap(D∙F, e2, e3)) A = (𝒟 e1 A ∧ 𝒟 e2 (A ⊔ 𝒜 e1) ∧ 𝒟 e3 (A ⊔ 𝒜 e1 ⊔ 𝒜 e2))"
| "𝒟 (e∙M(es)) A = (𝒟 e A ∧ 𝒟s es (A ⊔ 𝒜 e))"
| "𝒟 ({V:T=vo; e}) A = (if vo = None then 𝒟 e (A ⊖ V) else 𝒟 e (A ⊔ ⌊{V}⌋))"
| "𝒟 (sync⇘V⇙ (o') e) A = (𝒟 o' A ∧ 𝒟 e (A ⊔ 𝒜 o'))"
| "𝒟 (insync⇘V⇙ (a) e) A = 𝒟 e A"
| "𝒟 (e⇩1;;e⇩2) A = (𝒟 e⇩1 A ∧ 𝒟 e⇩2 (A ⊔ 𝒜 e⇩1))"
| "𝒟 (if (e) e⇩1 else e⇩2) A = (𝒟 e A ∧ 𝒟 e⇩1 (A ⊔ 𝒜 e) ∧ 𝒟 e⇩2 (A ⊔ 𝒜 e))"
| "𝒟 (while (e) c) A = (𝒟 e A ∧ 𝒟 c (A ⊔ 𝒜 e))"
| "𝒟 (throw e) A = 𝒟 e A"
| "𝒟 (try e⇩1 catch(C V) e⇩2) A = (𝒟 e⇩1 A ∧ 𝒟 e⇩2 (A ⊔ ⌊{V}⌋))"
| "𝒟s ([]) A = True"
| "𝒟s (e#es) A = (𝒟 e A ∧ 𝒟s es (A ⊔ 𝒜 e))"
lemma As_map_Val[simp]: "𝒜s (map Val vs) = ⌊{}⌋"
by (induct vs) simp_all
lemma As_append [simp]: "𝒜s (xs @ ys) = (𝒜s xs) ⊔ (𝒜s ys)"
by(induct xs, auto simp add: hyperset_defs)
lemma Ds_map_Val[simp]: "𝒟s (map Val vs) A"
by (induct vs) simp_all
lemma D_append[iff]: "⋀A. 𝒟s (es @ es') A = (𝒟s es A ∧ 𝒟s es' (A ⊔ 𝒜s es))"
by (induct es type:list) (auto simp:hyperUn_assoc)
lemma fixes e :: "('a,'b,'addr) exp" and es :: "('a,'b,'addr) exp list"
shows A_fv: "⋀A. 𝒜 e = ⌊A⌋ ⟹ A ⊆ fv e"
and "⋀A. 𝒜s es = ⌊A⌋ ⟹ A ⊆ fvs es"
apply(induct e and es rule: 𝒜.induct 𝒜s.induct)
apply (simp_all add:hyperset_defs)
apply fast+
done
lemma sqUn_lem: "A ⊑ A' ⟹ A ⊔ B ⊑ A' ⊔ B"
by(simp add:hyperset_defs) blast
lemma diff_lem: "A ⊑ A' ⟹ A ⊖ b ⊑ A' ⊖ b"
by(simp add:hyperset_defs) blast
lemma fixes e :: "('a, 'b, 'addr) exp" and es :: "('a, 'b, 'addr) exp list"
shows D_mono: "⋀A A'. A ⊑ A' ⟹ 𝒟 e A ⟹ 𝒟 e A'"
and Ds_mono: "⋀A A'. A ⊑ A' ⟹ 𝒟s es A ⟹ 𝒟s es A'"
apply(induct e and es rule: 𝒟.induct 𝒟s.induct)
subgoal by simp
subgoal by simp
subgoal by simp
subgoal by simp
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
subgoal by(fastforce simp add:hyperset_defs)
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp (iprover dest: sqUn_lem)
subgoal
apply(clarsimp split: if_split_asm)
apply (iprover dest:diff_lem)
apply(iprover dest: sqUn_lem)
done
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
subgoal by simp
subgoal by simp (iprover dest:sqUn_lem)
done
lemma D_mono': "𝒟 e A ⟹ A ⊑ A' ⟹ 𝒟 e A'"
and Ds_mono': "𝒟s es A ⟹ A ⊑ A' ⟹ 𝒟s es A'"
by(blast intro:D_mono, blast intro:Ds_mono)
declare hyperUn_comm [simp]
declare hyperUn_leftComm [simp]
end
Theory Threaded
section ‹The source language as an instance of the framework›
theory Threaded
imports
SmallStep
JWellForm
"../Common/ConformThreaded"
"../Common/ExternalCallWF"
"../Framework/FWLiftingSem"
"../Framework/FWProgressAux"
begin
context heap_base begin
lemma wset_Suspend_ok_start_state:
fixes final r convert_RA
assumes "start_state f P C M vs ∈ I"
shows "start_state f P C M vs ∈ multithreaded_base.wset_Suspend_ok final r convert_RA I"
using assms
by(rule multithreaded_base.wset_Suspend_okI)(simp add: start_state_def split_beta)
end
abbreviation final_expr :: "'addr expr × 'addr locals ⇒ bool"where
"final_expr ≡ λ(e, x). final e"
lemma final_locks: "final e ⟹ expr_locks e l = 0"
by(auto elim: finalE)
context J_heap_base begin
abbreviation mred
:: "'addr J_prog ⇒ ('addr, 'thread_id, 'addr expr × 'addr locals, 'heap, 'addr, ('addr, 'thread_id) obs_event) semantics"
where
"mred P t ≡ (λ((e, l), h) ta ((e', l'), h'). P,t ⊢ ⟨e, (h, l)⟩ -ta→ ⟨e', (h', l')⟩)"
lemma red_new_thread_heap:
"⟦ convert_extTA extNTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; NewThread t'' ex'' h'' ∈ set ⦃ta⦄⇘t⇙ ⟧ ⟹ h'' = hp s'"
and reds_new_thread_heap:
"⟦ convert_extTA extNTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; NewThread t'' ex'' h'' ∈ set ⦃ta⦄⇘t⇙ ⟧ ⟹ h'' = hp s'"
apply(induct rule: red_reds.inducts)
apply(fastforce dest: red_ext_new_thread_heap simp add: ta_upd_simps)+
done
lemma red_ta_Wakeup_no_Join_no_Lock_no_Interrupt:
"⟦ convert_extTA extNTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; Notified ∈ set ⦃ta⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta⦄⇘w⇙ ⟧
⟹ collect_locks ⦃ta⦄⇘l⇙ = {} ∧ collect_cond_actions ⦃ta⦄⇘c⇙ = {} ∧ collect_interrupts ⦃ta⦄⇘i⇙ = {}"
and reds_ta_Wakeup_no_Join_no_Lock_no_Interrupt:
"⟦ convert_extTA extNTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; Notified ∈ set ⦃ta⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta⦄⇘w⇙ ⟧
⟹ collect_locks ⦃ta⦄⇘l⇙ = {} ∧ collect_cond_actions ⦃ta⦄⇘c⇙ = {} ∧ collect_interrupts ⦃ta⦄⇘i⇙ = {}"
apply(induct rule: red_reds.inducts)
apply(auto simp add: ta_upd_simps dest: red_external_Wakeup_no_Join_no_Lock_no_Interrupt del: conjI)
done
lemma final_no_red:
"final e ⟹ ¬ P,t ⊢ ⟨e, (h, l)⟩ -ta→ ⟨e', (h', l')⟩"
by(auto elim: red.cases finalE)
lemma red_mthr: "multithreaded final_expr (mred P)"
by(unfold_locales)(auto dest: red_new_thread_heap)
end
sublocale J_heap_base < red_mthr: multithreaded
"final_expr"
"mred P"
convert_RA
for P
by(rule red_mthr)
context J_heap_base begin
abbreviation
mredT ::
"'addr J_prog ⇒ ('addr,'thread_id,'addr expr × 'addr locals,'heap,'addr) state
⇒ ('thread_id × ('addr, 'thread_id, 'addr expr × 'addr locals,'heap) Jinja_thread_action)
⇒ ('addr,'thread_id,'addr expr × 'addr locals,'heap,'addr) state ⇒ bool"
where
"mredT P ≡ red_mthr.redT P"
abbreviation
mredT_syntax1 :: "'addr J_prog ⇒ ('addr,'thread_id,'addr expr × 'addr locals,'heap,'addr) state
⇒ 'thread_id ⇒ ('addr, 'thread_id, 'addr expr × 'addr locals,'heap) Jinja_thread_action
⇒ ('addr,'thread_id,'addr expr × 'addr locals,'heap,'addr) state ⇒ bool"
("_ ⊢ _ -_▹_→ _" [50,0,0,0,50] 80)
where
"mredT_syntax1 P s t ta s' ≡ mredT P s (t, ta) s'"
abbreviation
mRedT_syntax1 ::
"'addr J_prog
⇒ ('addr,'thread_id,'addr expr × 'addr locals,'heap,'addr) state
⇒ ('thread_id × ('addr, 'thread_id, 'addr expr × 'addr locals,'heap) Jinja_thread_action) list
⇒ ('addr,'thread_id,'addr expr × 'addr locals,'heap,'addr) state ⇒ bool"
("_ ⊢ _ -▹_→* _" [50,0,0,50] 80)
where
"P ⊢ s -▹ttas→* s' ≡ red_mthr.RedT P s ttas s'"
end
context J_heap begin
lemma redT_hext_incr:
"P ⊢ s -t▹ta→ s' ⟹ shr s ⊴ shr s'"
by(erule red_mthr.redT.cases)(auto dest!: red_hext_incr intro: hext_trans)
lemma RedT_hext_incr:
assumes "P ⊢ s -▹tta→* s'"
shows "shr s ⊴ shr s'"
using assms unfolding red_mthr.RedT_def
by(induct)(auto dest: redT_hext_incr intro: hext_trans)
end
subsection ‹Lifting @{term "tconf"} to multithreaded states›
context J_heap begin
lemma red_NewThread_Thread_Object:
"⟦ convert_extTA extNTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; NewThread t' x m ∈ set ⦃ta⦄⇘t⇙ ⟧
⟹ ∃C. typeof_addr (hp s') (thread_id2addr t') = ⌊Class_type C⌋ ∧ P ⊢ C ≼⇧* Thread"
and reds_NewThread_Thread_Object:
"⟦ convert_extTA extNTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; NewThread t' x m ∈ set ⦃ta⦄⇘t⇙ ⟧
⟹ ∃C. typeof_addr (hp s') (thread_id2addr t') = ⌊Class_type C⌋ ∧ P ⊢ C ≼⇧* Thread"
apply(induct rule: red_reds.inducts)
apply(fastforce dest: red_external_new_thread_exists_thread_object simp add: ta_upd_simps)+
done
lemma lifting_wf_tconf:
"lifting_wf final_expr (mred P) (λt ex h. P,h ⊢ t √t)"
by(unfold_locales)(fastforce dest: red_hext_incr red_NewThread_Thread_Object elim!: tconf_hext_mono intro: tconfI)+
end
sublocale J_heap < red_tconf: lifting_wf final_expr "mred P" convert_RA "λt ex h. P,h ⊢ t √t"
by(rule lifting_wf_tconf)
subsection ‹Towards agreement between the framework semantics' lock state and the locks stored in the expressions›
primrec sync_ok :: "('a,'b,'addr) exp ⇒ bool"
and sync_oks :: "('a,'b,'addr) exp list ⇒ bool"
where
"sync_ok (new C) = True"
| "sync_ok (newA T⌊i⌉) = sync_ok i"
| "sync_ok (Cast T e) = sync_ok e"
| "sync_ok (e instanceof T) = sync_ok e"
| "sync_ok (Val v) = True"
| "sync_ok (Var v) = True"
| "sync_ok (e «bop» e') = (sync_ok e ∧ sync_ok e' ∧ (contains_insync e' ⟶ is_val e))"
| "sync_ok (V := e) = sync_ok e"
| "sync_ok (a⌊i⌉) = (sync_ok a ∧ sync_ok i ∧ (contains_insync i ⟶ is_val a))"
| "sync_ok (AAss a i e) = (sync_ok a ∧ sync_ok i ∧ sync_ok e ∧ (contains_insync i ⟶ is_val a) ∧ (contains_insync e ⟶ is_val a ∧ is_val i))"
| "sync_ok (a∙length) = sync_ok a"
| "sync_ok (e∙F{D}) = sync_ok e"
| "sync_ok (FAss e F D e') = (sync_ok e ∧ sync_ok e' ∧ (contains_insync e' ⟶ is_val e))"
| "sync_ok (e∙compareAndSwap(D∙F, e', e'')) = (sync_ok e ∧ sync_ok e' ∧ sync_ok e'' ∧ (contains_insync e' ⟶ is_val e) ∧ (contains_insync e'' ⟶ is_val e ∧ is_val e'))"
| "sync_ok (e∙m(pns)) = (sync_ok e ∧ sync_oks pns ∧ (contains_insyncs pns ⟶ is_val e))"
| "sync_ok ({V : T=vo; e}) = sync_ok e"
| "sync_ok (sync⇘V⇙ (o') e) = (sync_ok o' ∧ ¬ contains_insync e)"
| "sync_ok (insync⇘V⇙ (a) e) = sync_ok e"
| "sync_ok (e;;e') = (sync_ok e ∧ ¬ contains_insync e')"
| "sync_ok (if (b) e else e') = (sync_ok b ∧ ¬ contains_insync e ∧ ¬ contains_insync e')"
| "sync_ok (while (b) e) = (¬ contains_insync b ∧ ¬ contains_insync e)"
| "sync_ok (throw e) = sync_ok e"
| "sync_ok (try e catch(C v) e') = (sync_ok e ∧ ¬ contains_insync e')"
| "sync_oks [] = True"
| "sync_oks (x # xs) = (sync_ok x ∧ sync_oks xs ∧ (contains_insyncs xs ⟶ is_val x))"
lemma sync_oks_append [simp]:
"sync_oks (xs @ ys) ⟷ sync_oks xs ∧ sync_oks ys ∧ (contains_insyncs ys ⟶ (∃vs. xs = map Val vs))"
by(induct xs)(auto simp add: Cons_eq_map_conv)
lemma fixes e :: "('a,'b,'addr) exp" and es :: "('a,'b,'addr) exp list"
shows not_contains_insync_sync_ok: "¬ contains_insync e ⟹ sync_ok e"
and not_contains_insyncs_sync_oks: "¬ contains_insyncs es ⟹ sync_oks es"
by(induct e and es rule: sync_ok.induct sync_oks.induct)(auto)
lemma expr_locks_sync_ok: "(⋀ad. expr_locks e ad = 0) ⟹ sync_ok e"
and expr_lockss_sync_oks: "(⋀ad. expr_lockss es ad = 0) ⟹ sync_oks es"
by(auto intro!: not_contains_insync_sync_ok not_contains_insyncs_sync_oks
simp add: contains_insync_conv contains_insyncs_conv)
lemma sync_ok_extRet2J [simp, intro!]: "sync_ok e ⟹ sync_ok (extRet2J e va)"
by(cases va) auto
abbreviation
sync_es_ok :: "('addr,'thread_id,('a,'b,'addr) exp×'c) thread_info ⇒ 'heap ⇒ bool"
where
"sync_es_ok ≡ ts_ok (λt (e, x) m. sync_ok e)"
lemma sync_es_ok_blocks [simp]:
"⟦ length pns = length Ts; length Ts = length vs ⟧ ⟹ sync_ok (blocks pns Ts vs e) = sync_ok e"
by(induct pns Ts vs e rule: blocks.induct) auto
context J_heap_base begin
lemma assumes wf: "wf_J_prog P"
shows red_preserve_sync_ok: "⟦ extTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; sync_ok e ⟧ ⟹ sync_ok e'"
and reds_preserve_sync_oks: "⟦ extTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; sync_oks es ⟧ ⟹ sync_oks es'"
proof(induct rule: red_reds.inducts)
case (RedCall s a U M Ts T pns body D vs)
from wf ‹P ⊢ class_type_of U sees M: Ts→T = ⌊(pns, body)⌋ in D›
have "wf_mdecl wf_J_mdecl P D (M,Ts,T,⌊(pns,body)⌋)"
by(rule sees_wf_mdecl)
then obtain T where "P,[this↦Class D,pns[↦]Ts] ⊢ body :: T"
by(auto simp add: wf_mdecl_def)
hence "expr_locks body = (λad. 0)" by(rule WT_expr_locks)
with ‹length vs = length pns› ‹length Ts = length pns›
have "expr_locks (blocks pns Ts vs body) = (λad. 0)"
by(simp add: expr_locks_blocks)
thus ?case by(auto intro: expr_locks_sync_ok)
qed(fastforce intro: not_contains_insync_sync_ok)+
lemma assumes wf: "wf_J_prog P"
shows expr_locks_new_thread:
"⟦ P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; NewThread t'' (e'', x'') h ∈ set ⦃ta⦄⇘t⇙ ⟧ ⟹ expr_locks e'' = (λad. 0)"
and expr_locks_new_thread':
"⟦ P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; NewThread t'' (e'', x'') h ∈ set ⦃ta⦄⇘t⇙ ⟧ ⟹ expr_locks e'' = (λad. 0)"
proof(induct rule: red_reds.inducts)
case (RedCallExternal s a U M Ts T D vs ta va h' ta' e' s')
then obtain C fs a where subThread: "P ⊢ C ≼⇧* Thread" and ext: "extNTA2J P (C, run, a) = (e'', x'')"
by(fastforce dest: red_external_new_thread_sub_thread)
from sub_Thread_sees_run[OF wf subThread] obtain D pns body
where sees: "P ⊢ C sees run: []→Void = ⌊(pns, body)⌋ in D" by auto
from sees_wf_mdecl[OF wf this] obtain T where "P,[this ↦ Class D] ⊢ body :: T"
by(auto simp add: wf_mdecl_def)
hence "expr_locks body = (λad. 0)" by(rule WT_expr_locks)
with sees ext show ?case by(auto simp add: extNTA2J_def)
qed(auto simp add: ta_upd_simps)
lemma assumes wf: "wf_J_prog P"
shows red_new_thread_sync_ok: "⟦ P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; NewThread t'' (e'', x'') h'' ∈ set ⦃ta⦄⇘t⇙ ⟧ ⟹ sync_ok e''"
and reds_new_thread_sync_ok: "⟦ P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; NewThread t'' (e'', x'') h'' ∈ set ⦃ta⦄⇘t⇙ ⟧ ⟹ sync_ok e''"
by(auto dest!: expr_locks_new_thread[OF wf] expr_locks_new_thread'[OF wf] intro: expr_locks_sync_ok expr_lockss_sync_oks)
lemma lifting_wf_sync_ok: "wf_J_prog P ⟹ lifting_wf final_expr (mred P) (λt (e, x) m. sync_ok e)"
by(unfold_locales)(auto intro: red_preserve_sync_ok red_new_thread_sync_ok)
lemma redT_preserve_sync_ok:
assumes red: "P ⊢ s -t▹ta→ s'"
shows "⟦ wf_J_prog P; sync_es_ok (thr s) (shr s) ⟧ ⟹ sync_es_ok (thr s') (shr s')"
by(rule lifting_wf.redT_preserves[OF lifting_wf_sync_ok red])
lemma RedT_preserves_sync_ok:
"⟦wf_J_prog P; P ⊢ s -▹ttas→* s'; sync_es_ok (thr s) (shr s)⟧
⟹ sync_es_ok (thr s') (shr s')"
by(rule lifting_wf.RedT_preserves[OF lifting_wf_sync_ok])
lemma sync_es_ok_J_start_state:
"⟦ wf_J_prog P; P ⊢ C sees M:Ts→T=⌊(pns, body)⌋ in D; length Ts = length vs ⟧
⟹ sync_es_ok (thr (J_start_state P C M vs)) m"
apply(rule ts_okI)
apply(clarsimp simp add: start_state_def split_beta split: if_split_asm)
apply(drule (1) sees_wf_mdecl)
apply(clarsimp simp add: wf_mdecl_def)
apply(drule WT_expr_locks)
apply(rule expr_locks_sync_ok)
apply simp
done
end
text ‹Framework lock state agrees with locks stored in the expression›
definition lock_ok :: "('addr,'thread_id) locks ⇒ ('addr,'thread_id,('a, 'b,'addr) exp × 'x) thread_info ⇒ bool" where
"⋀ln. lock_ok ls ts ≡ ∀t. (case (ts t) of None ⇒ (∀l. has_locks (ls $ l) t = 0)
| ⌊((e, x), ln)⌋ ⇒ (∀l. has_locks (ls $ l) t + ln $ l = expr_locks e l))"
lemma lock_okI:
"⟦ ⋀t l. ts t = None ⟹ has_locks (ls $ l) t = 0; ⋀t e x ln l. ts t = ⌊((e, x), ln)⌋ ⟹ has_locks (ls $ l) t + ln $ l= expr_locks e l ⟧ ⟹ lock_ok ls ts"
apply(fastforce simp add: lock_ok_def)
done
lemma lock_okE:
"⟦ lock_ok ls ts;
∀t. ts t = None ⟶ (∀l. has_locks (ls $ l) t = 0) ⟹ Q;
∀t e x ln. ts t = ⌊((e, x), ln)⌋ ⟶ (∀l. has_locks (ls $ l) t + ln $ l = expr_locks e l) ⟹ Q ⟧
⟹ Q"
by(fastforce simp add: lock_ok_def)
lemma lock_okD1:
"⟦ lock_ok ls ts; ts t = None ⟧ ⟹ ∀l. has_locks (ls $ l) t = 0"
apply(simp add: lock_ok_def)
apply(erule_tac x="t" in allE)
apply(auto)
done
lemma lock_okD2:
"⋀ln. ⟦ lock_ok ls ts; ts t = ⌊((e, x), ln)⌋ ⟧ ⟹ ∀l. has_locks (ls $ l) t + ln $ l = expr_locks e l"
apply(fastforce simp add: lock_ok_def)
done
lemma lock_ok_lock_thread_ok:
assumes lock: "lock_ok ls ts"
shows "lock_thread_ok ls ts"
proof(rule lock_thread_okI)
fix l t
assume lsl: "has_lock (ls $ l) t"
show "∃xw. ts t = ⌊xw⌋"
proof(cases "ts t")
case None
with lock have "has_locks (ls $ l) t = 0"
by(auto dest: lock_okD1)
with lsl show ?thesis by simp
next
case (Some a) thus ?thesis by blast
qed
qed
lemma (in J_heap_base) lock_ok_J_start_state:
"⟦ wf_J_prog P; P ⊢ C sees M:Ts→T=⌊(pns, body)⌋ in D; length Ts = length vs ⟧
⟹ lock_ok (locks (J_start_state P C M vs)) (thr (J_start_state P C M vs))"
apply(rule lock_okI)
apply(auto simp add: start_state_def split: if_split_asm)
apply(drule (1) sees_wf_mdecl)
apply(clarsimp simp add: wf_mdecl_def)
apply(drule WT_expr_locks)
apply(simp add: expr_locks_blocks)
done
subsection ‹Preservation of lock state agreement›
fun upd_expr_lock_action :: "int ⇒ lock_action ⇒ int"
where
"upd_expr_lock_action i Lock = i + 1"
| "upd_expr_lock_action i Unlock = i - 1"
| "upd_expr_lock_action i UnlockFail = i"
| "upd_expr_lock_action i ReleaseAcquire = i"
fun upd_expr_lock_actions :: "int ⇒ lock_action list ⇒ int" where
"upd_expr_lock_actions n [] = n"
| "upd_expr_lock_actions n (L # Ls) = upd_expr_lock_actions (upd_expr_lock_action n L) Ls"
lemma upd_expr_lock_actions_append [simp]:
"upd_expr_lock_actions n (Ls @ Ls') = upd_expr_lock_actions (upd_expr_lock_actions n Ls) Ls'"
by(induct Ls arbitrary: n, auto)
definition upd_expr_locks :: "('l ⇒ int) ⇒ 'l lock_actions ⇒ 'l ⇒ int"
where "upd_expr_locks els las ≡ λl. upd_expr_lock_actions (els l) (las $ l)"
lemma upd_expr_locks_iff [simp]:
"upd_expr_locks els las l = upd_expr_lock_actions (els l) (las $ l)"
by(simp add: upd_expr_locks_def)
lemma upd_expr_lock_action_add [simp]:
"upd_expr_lock_action (l + l') L = upd_expr_lock_action l L + l'"
by(cases L, auto)
lemma upd_expr_lock_actions_add [simp]:
"upd_expr_lock_actions (l + l') Ls = upd_expr_lock_actions l Ls + l'"
by(induct Ls arbitrary: l, auto)
lemma upd_expr_locks_add [simp]:
"upd_expr_locks (λa. x a + y a) las = (λa. upd_expr_locks x las a + y a)"
by(auto intro: ext)
lemma expr_locks_extRet2J [simp, intro!]: "expr_locks e = (λad. 0) ⟹ expr_locks (extRet2J e va) = (λad. 0)"
by(cases va) auto
lemma (in J_heap_base)
assumes wf: "wf_J_prog P"
shows red_update_expr_locks:
"⟦ convert_extTA extNTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; sync_ok e ⟧
⟹ upd_expr_locks (int o expr_locks e) ⦃ta⦄⇘l⇙ = int o expr_locks e'"
and reds_update_expr_lockss:
"⟦ convert_extTA extNTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; sync_oks es ⟧
⟹ upd_expr_locks (int o expr_lockss es) ⦃ta⦄⇘l⇙ = int o expr_lockss es'"
proof -
have "⟦ convert_extTA extNTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; sync_ok e ⟧
⟹ upd_expr_locks (λad. 0) ⦃ta⦄⇘l⇙ = (λad. (int o expr_locks e') ad - (int o expr_locks e) ad)"
and "⟦ convert_extTA extNTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; sync_oks es ⟧
⟹ upd_expr_locks (λad. 0) ⦃ta⦄⇘l⇙ = (λad. (int o expr_lockss es') ad - (int o expr_lockss es) ad)"
proof(induct rule: red_reds.inducts)
case (RedCall s a U M Ts T pns body D vs)
from wf ‹P ⊢ class_type_of U sees M: Ts→T = ⌊(pns, body)⌋ in D›
have "wf_mdecl wf_J_mdecl P D (M,Ts,T,⌊(pns,body)⌋)"
by(rule sees_wf_mdecl)
then obtain T where "P,[this↦Class D,pns[↦]Ts] ⊢ body :: T"
by(auto simp add: wf_mdecl_def)
hence "expr_locks body = (λad. 0)" by(rule WT_expr_locks)
with ‹length vs = length pns› ‹length Ts = length pns›
have "expr_locks (blocks pns Ts vs body) = (λad. 0)"
by(simp add: expr_locks_blocks)
thus ?case by(auto intro: expr_locks_sync_ok)
next
case RedCallExternal thus ?case
by(auto simp add: fun_eq_iff contains_insync_conv contains_insyncs_conv finfun_upd_apply ta_upd_simps elim!: red_external.cases)
qed(fastforce simp add: fun_eq_iff contains_insync_conv contains_insyncs_conv finfun_upd_apply ta_upd_simps)+
hence "⟦ convert_extTA extNTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; sync_ok e ⟧
⟹ upd_expr_locks (λad. 0 + (int ∘ expr_locks e) ad) ⦃ta⦄⇘l⇙ = int ∘ expr_locks e'"
and "⟦ convert_extTA extNTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; sync_oks es ⟧
⟹ upd_expr_locks (λad. 0 + (int ∘ expr_lockss es) ad) ⦃ta⦄⇘l⇙ = int ∘ expr_lockss es'"
by(auto intro: ext simp only: upd_expr_locks_add)
thus "⟦ convert_extTA extNTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; sync_ok e ⟧
⟹ upd_expr_locks (int o expr_locks e) ⦃ta⦄⇘l⇙ = int o expr_locks e'"
and "⟦ convert_extTA extNTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; sync_oks es ⟧
⟹ upd_expr_locks (int o expr_lockss es) ⦃ta⦄⇘l⇙ = int o expr_lockss es'"
by(auto simp add: o_def)
qed
definition lock_expr_locks_ok :: "'t FWState.lock ⇒ 't ⇒ nat ⇒ int ⇒ bool" where
"lock_expr_locks_ok l t n i ≡ (i = int (has_locks l t) + int n) ∧ i ≥ 0"
lemma upd_lock_upd_expr_lock_action_preserve_lock_expr_locks_ok:
assumes lao: "lock_action_ok l t L"
and lelo: "lock_expr_locks_ok l t n i"
shows "lock_expr_locks_ok (upd_lock l t L) t (upd_threadR n l t L) (upd_expr_lock_action i L)"
proof -
from lelo have i: "i ≥ 0"
and hl: "i = int (has_locks l t) + int n"
by(auto simp add: lock_expr_locks_ok_def)
from lelo
show ?thesis
proof(cases L)
case Lock
with lao have "may_lock l t" by(simp)
with hl have "has_locks (lock_lock l t) t = (Suc (has_locks l t))" by(auto)
with Lock i hl show ?thesis
by(simp add: lock_expr_locks_ok_def)
next
case Unlock
with lao have "has_lock l t" by simp
then obtain n'
where hl': "has_locks l t = Suc n'"
by(auto dest: has_lock_has_locks_Suc)
hence "has_locks (unlock_lock l) t = n'" by simp
with Unlock i hl hl' show ?thesis
by(simp add: lock_expr_locks_ok_def)
qed(auto simp add: lock_expr_locks_ok_def)
qed
lemma upd_locks_upd_expr_lock_preserve_lock_expr_locks_ok:
"⟦ lock_actions_ok l t Ls; lock_expr_locks_ok l t n i ⟧
⟹ lock_expr_locks_ok (upd_locks l t Ls) t (upd_threadRs n l t Ls) (upd_expr_lock_actions i Ls)"
by(induct Ls arbitrary: l i n)(auto intro: upd_lock_upd_expr_lock_action_preserve_lock_expr_locks_ok)
definition ls_els_ok :: "('addr,'thread_id) locks ⇒ 'thread_id ⇒ ('addr ⇒f nat) ⇒ ('addr ⇒ int) ⇒ bool" where
"⋀ln. ls_els_ok ls t ln els ≡ ∀l. lock_expr_locks_ok (ls $ l) t (ln $ l) (els l)"
lemma ls_els_okI:
"⋀ln. (⋀l. lock_expr_locks_ok (ls $ l) t (ln $ l) (els l)) ⟹ ls_els_ok ls t ln els"
by(auto simp add: ls_els_ok_def)
lemma ls_els_okE:
"⋀ln. ⟦ ls_els_ok ls t ln els; ∀l. lock_expr_locks_ok (ls $ l) t (ln $ l) (els l) ⟹ P ⟧ ⟹ P"
by(auto simp add: ls_els_ok_def)
lemma ls_els_okD:
"⋀ln. ls_els_ok ls t ln els ⟹ lock_expr_locks_ok (ls $ l) t (ln $ l) (els l)"
by(auto simp add: ls_els_ok_def)
lemma redT_updLs_upd_expr_locks_preserves_ls_els_ok:
"⋀ln. ⟦ ls_els_ok ls t ln els; lock_ok_las ls t las ⟧
⟹ ls_els_ok (redT_updLs ls t las) t (redT_updLns ls t ln las) (upd_expr_locks els las)"
by(auto intro!: ls_els_okI upd_locks_upd_expr_lock_preserve_lock_expr_locks_ok elim!: ls_els_okE simp add: redT_updLs_def lock_ok_las_def)
lemma sync_ok_redT_updT:
assumes "sync_es_ok ts h"
and nt: "⋀t e x h''. ta = NewThread t (e, x) h'' ⟹ sync_ok e"
shows "sync_es_ok (redT_updT ts ta) h'"
using assms
proof(cases ta)
case (NewThread T x m)
obtain E X where [simp]: "x = (E, X)" by (cases x, auto)
with NewThread have "sync_ok E" by(simp)(rule nt)
with NewThread ‹sync_es_ok ts h› show ?thesis
apply -
apply(rule ts_okI)
apply(case_tac "t=T")
by(auto dest: ts_okD)
qed(auto intro: ts_okI dest: ts_okD)
lemma sync_ok_redT_updTs:
"⟦ sync_es_ok ts h; ⋀t e x h. NewThread t (e, x) h ∈ set tas ⟹ sync_ok e ⟧
⟹ sync_es_ok (redT_updTs ts tas) h'"
proof(induct tas arbitrary: ts)
case Nil thus ?case by(auto intro: ts_okI dest: ts_okD)
next
case (Cons TA TAS TS)
note IH = ‹⋀ts. ⟦sync_es_ok ts h; ⋀t e x h''. NewThread t (e, x) h'' ∈ set TAS ⟹ sync_ok e⟧
⟹ sync_es_ok (redT_updTs ts TAS) h'›
note nt = ‹⋀t e x h. NewThread t (e, x) h ∈ set (TA # TAS) ⟹ sync_ok e›
from ‹sync_es_ok TS h› nt
have "sync_es_ok (redT_updT TS TA) h"
by(auto elim!: sync_ok_redT_updT)
hence "sync_es_ok (redT_updTs (redT_updT TS TA) TAS) h'"
by(rule IH)(auto intro: nt)
thus ?case by simp
qed
lemma lock_ok_thr_updI:
"⋀ln. ⟦ lock_ok ls ts; ts t = ⌊((e, xs), ln)⌋; expr_locks e = expr_locks e' ⟧
⟹ lock_ok ls (ts(t ↦ ((e', xs'), ln)))"
by(rule lock_okI)(auto split: if_split_asm dest: lock_okD2 lock_okD1)
context J_heap_base begin
lemma redT_preserves_lock_ok:
assumes wf: "wf_J_prog P"
and "P ⊢ s -t▹ta→ s'"
and "lock_ok (locks s) (thr s)"
and "sync_es_ok (thr s) (shr s)"
shows "lock_ok (locks s') (thr s')"
proof -
obtain ls ts h ws "is" where s [simp]: "s = (ls, (ts, h), ws, is)" by(cases s) fastforce
obtain ls' ts' h' ws' is' where s' [simp]: "s' = (ls', (ts', h'), ws', is')" by(cases s') fastforce
from assms have redT: "P ⊢ (ls, (ts, h), ws, is) -t▹ta→ (ls', (ts', h'), ws', is')"
and loes: "lock_ok ls ts"
and aoes: "sync_es_ok ts h" by auto
from redT have "lock_ok ls' ts'"
proof(cases rule: red_mthr.redT_elims)
case (normal a a' m')
moreover obtain e x where "a = (e, x)" by (cases a, auto)
moreover obtain e' x' where "a' = (e', x')" by (cases a', auto)
ultimately have P: "P,t ⊢ ⟨e,(h, x)⟩ -ta→ ⟨e',(m', x')⟩"
and est: "ts t = ⌊((e, x), no_wait_locks)⌋"
and lota: "lock_ok_las ls t ⦃ta⦄⇘l⇙"
and cctta: "thread_oks ts ⦃ta⦄⇘t⇙"
and ls': "ls' = redT_updLs ls t ⦃ta⦄⇘l⇙"
and s': "ts' = redT_updTs ts ⦃ta⦄⇘t⇙(t ↦ ((e', x'), redT_updLns ls t no_wait_locks ⦃ta⦄⇘l⇙))"
by auto
let ?ts' = "redT_updTs ts ⦃ta⦄⇘t⇙(t ↦ ((e', x'), redT_updLns ls t no_wait_locks ⦃ta⦄⇘l⇙))"
from est aoes have aoe: "sync_ok e" by(auto dest: ts_okD)
from aoe P have aoe': "sync_ok e'" by(auto dest: red_preserve_sync_ok[OF wf])
from aoes red_new_thread_sync_ok[OF wf P]
have "sync_es_ok (redT_updTs ts ⦃ta⦄⇘t⇙) h'"
by(rule sync_ok_redT_updTs)
with aoe' have aoes': "sync_es_ok ?ts' m'"
by(auto intro!: ts_okI dest: ts_okD split: if_split_asm)
have "lock_ok ls' ?ts'"
proof(rule lock_okI)
fix t'' l
assume "?ts' t'' = None"
hence "ts t'' = None"
by(auto split: if_split_asm intro: redT_updTs_None)
with loes have "has_locks (ls $ l) t'' = 0"
by(auto dest: lock_okD1)
moreover from ‹?ts' t'' = None›
have "t ≠ t''" by(simp split: if_split_asm)
ultimately show "has_locks (ls' $ l) t'' = 0"
by(simp add: red_mthr.redT_has_locks_inv[OF redT])
next
fix t'' e'' x'' l ln''
assume ts't'': "?ts' t'' = ⌊((e'', x''), ln'')⌋"
with aoes' have aoe'': "sync_ok e''" by(auto dest: ts_okD)
show "has_locks (ls' $ l) t'' + ln'' $ l = expr_locks e'' l"
proof(cases "t = t''")
case True
note tt'' = ‹t = t''›
with ts't'' have e'': "e'' = e'" and x'': "x'' = x'"
and ln'': "ln'' = redT_updLns ls t no_wait_locks ⦃ta⦄⇘l⇙" by auto
have "ls_els_ok ls t no_wait_locks (int o expr_locks e)"
proof(rule ls_els_okI)
fix l
note lock_okD2[OF loes, OF est]
thus "lock_expr_locks_ok (ls $ l) t (no_wait_locks $ l) ((int ∘ expr_locks e) l)"
by(simp add: lock_expr_locks_ok_def)
qed
hence "ls_els_ok (redT_updLs ls t ⦃ta⦄⇘l⇙) t (redT_updLns ls t no_wait_locks ⦃ta⦄⇘l⇙) (upd_expr_locks (int o expr_locks e) ⦃ta⦄⇘l⇙)"
by(rule redT_updLs_upd_expr_locks_preserves_ls_els_ok[OF _ lota])
hence "ls_els_ok (redT_updLs ls t ⦃ta⦄⇘l⇙) t (redT_updLns ls t no_wait_locks ⦃ta⦄⇘l⇙) (int o expr_locks e')"
by(simp only: red_update_expr_locks[OF wf P aoe])
thus ?thesis using ls' e'' tt'' ln''
by(auto dest: ls_els_okD[where l = l] simp: lock_expr_locks_ok_def)
next
case False
note tt'' = ‹t ≠ t''›
from lota have lao: "lock_actions_ok (ls $ l) t (⦃ta⦄⇘l⇙ $ l)"
by(simp add: lock_ok_las_def)
show ?thesis
proof(cases "ts t''")
case None
with est ts't'' tt'' cctta
obtain m where "NewThread t'' (e'', x'') m ∈ set ⦃ta⦄⇘t⇙" and ln'': "ln'' = no_wait_locks"
by(auto dest: redT_updTs_new_thread)
moreover with P have "m' = m" by(auto dest: red_new_thread_heap)
ultimately have "NewThread t'' (e'', x'') m' ∈ set ⦃ta⦄⇘t⇙" by simp
with wf P ln'' have "expr_locks e'' = (λad. 0)"
by -(rule expr_locks_new_thread)
hence elel: "expr_locks e'' l = 0" by simp
from loes None have "has_locks (ls $ l) t'' = 0"
by(auto dest: lock_okD1)
moreover note lock_actions_ok_has_locks_upd_locks_eq_has_locks[OF lao tt''[symmetric]]
ultimately have "has_locks (redT_updLs ls t ⦃ta⦄⇘l⇙ $ l) t'' = 0"
by(auto simp add: fun_eq_iff)
with elel ls' ln'' show ?thesis by(auto)
next
case (Some a)
then obtain E X LN where est'': "ts t'' = ⌊((E, X), LN)⌋" by(cases a, auto)
with loes have IH: "has_locks (ls $ l) t'' + LN $ l = expr_locks E l"
by(auto dest: lock_okD2)
from est est'' tt'' cctta have "?ts' t'' = ⌊((E, X), LN)⌋"
by(simp)(rule redT_updTs_Some, simp_all)
with ts't'' have e'': "E = e''" and x'': "X = x''"
and ln'': "ln'' = LN" by(simp_all)
with lock_actions_ok_has_locks_upd_locks_eq_has_locks[OF lao tt''[symmetric]] IH ls'
show ?thesis by(clarsimp simp add: redT_updLs_def fun_eq_iff)
qed
qed
qed
with s' show ?thesis by simp
next
case (acquire a ln n)
hence [simp]: "ta = (K$ [], [], [], [], [], convert_RA ln)" "ws' = ws" "h' = h"
and ls': "ls' = acquire_all ls t ln"
and ts': "ts' = ts(t ↦ (a, no_wait_locks))"
and "ts t = ⌊(a, ln)⌋"
and "may_acquire_all ls t ln"
by auto
obtain e x where [simp]: "a = (e, x)" by (cases a, auto)
from ts' have ts': "ts' = ts(t ↦ ((e, x), no_wait_locks))" by simp
from ‹ts t = ⌊(a, ln)⌋› have tst: "ts t = ⌊((e, x), ln)⌋" by simp
show ?thesis
proof(rule lock_okI)
fix t'' l
assume rtutes: "ts' t'' = None"
with ts' have tst'': "ts t'' = None"
by(simp split: if_split_asm)
with tst have tt'': "t ≠ t''" by auto
from tst'' loes have "has_locks (ls $ l) t'' = 0"
by(auto dest: lock_okD1)
thus "has_locks (ls' $ l) t'' = 0"
by(simp add: red_mthr.redT_has_locks_inv[OF redT tt''])
next
fix t'' e'' x'' ln'' l
assume ts't'': "ts' t'' = ⌊((e'', x''), ln'')⌋"
show "has_locks (ls' $ l) t'' + ln'' $ l = expr_locks e'' l"
proof(cases "t = t''")
case True
note [simp] = this
with ts't'' ts' tst
have [simp]: "ln'' = no_wait_locks" "e = e''" by auto
from tst loes have "has_locks (ls $ l) t + ln $ l = expr_locks e l"
by(auto dest: lock_okD2)
show ?thesis
proof(cases "ln $ l > 0")
case True
with ‹may_acquire_all ls t ln› ls' have "may_lock (ls $ l) t"
by(auto elim: may_acquire_allE)
with ls'
have "has_locks (ls' $ l) t = has_locks (ls $ l) t + ln $ l"
by(simp add: has_locks_acquire_locks_conv)
with ‹has_locks (ls $ l) t + ln $ l = expr_locks e l›
show ?thesis by(simp)
next
case False
hence "ln $ l = 0" by simp
with ls' have "has_locks (ls' $ l) t = has_locks (ls $ l) t"
by(simp)
with ‹has_locks (ls $ l) t + ln $ l = expr_locks e l› ‹ln $ l = 0›
show ?thesis by(simp)
qed
next
case False
with ts' ts't'' have tst'': "ts t'' = ⌊((e'', x''), ln'')⌋" by(simp)
with loes have "has_locks (ls $ l) t'' + ln'' $ l = expr_locks e'' l"
by(auto dest: lock_okD2)
show ?thesis
proof(cases "ln $ l > 0")
case False
with ‹t ≠ t''› ls'
have "has_locks (ls' $ l) t'' = has_locks (ls $ l) t''" by(simp)
with ‹has_locks (ls $ l) t'' + ln'' $ l = expr_locks e'' l›
show ?thesis by(simp)
next
case True
with ‹may_acquire_all ls t ln› have "may_lock (ls $ l) t"
by(auto elim: may_acquire_allE)
with ls' ‹t ≠ t''› have "has_locks (ls' $ l) t'' = has_locks (ls $ l) t''"
by(simp add: has_locks_acquire_locks_conv')
with ls' ‹has_locks (ls $ l) t'' + ln'' $ l = expr_locks e'' l›
show ?thesis by(simp)
qed
qed
qed
qed
thus ?thesis by simp
qed
lemma invariant3p_sync_es_ok_lock_ok:
assumes wf: "wf_J_prog P"
shows "invariant3p (mredT P) {s. sync_es_ok (thr s) (shr s) ∧ lock_ok (locks s) (thr s)}"
apply(rule invariant3pI)
apply clarify
apply(rule conjI)
apply(rule lifting_wf.redT_preserves[OF lifting_wf_sync_ok[OF wf]], blast)
apply(assumption)
apply(erule (2) redT_preserves_lock_ok[OF wf])
done
lemma RedT_preserves_lock_ok:
assumes wf: "wf_J_prog P"
and Red: "P ⊢ s -▹ttas→* s'"
and ae: "sync_es_ok (thr s) (shr s)"
and loes: "lock_ok (locks s) (thr s)"
shows "lock_ok (locks s') (thr s')"
using invariant3p_rtrancl3p[OF invariant3p_sync_es_ok_lock_ok[OF wf] Red[unfolded red_mthr.RedT_def]] ae loes
by simp
end
subsection ‹Determinism›
context J_heap_base begin
lemma
fixes final
assumes det: "deterministic_heap_ops"
shows red_deterministic:
"⟦ convert_extTA extTA,P,t ⊢ ⟨e, (shr s, xs)⟩ -ta→ ⟨e', s'⟩;
convert_extTA extTA,P,t ⊢ ⟨e, (shr s, xs)⟩ -ta'→ ⟨e'', s''⟩;
final_thread.actions_ok final s t ta; final_thread.actions_ok final s t ta' ⟧
⟹ ta = ta' ∧ e' = e'' ∧ s' = s''"
and reds_deterministic:
"⟦ convert_extTA extTA,P,t ⊢ ⟨es, (shr s, xs)⟩ [-ta→] ⟨es', s'⟩;
convert_extTA extTA,P,t ⊢ ⟨es, (shr s, xs)⟩ [-ta'→] ⟨es'', s''⟩;
final_thread.actions_ok final s t ta; final_thread.actions_ok final s t ta' ⟧
⟹ ta = ta' ∧ es' = es'' ∧ s' = s''"
proof(induct e "(shr s, xs)" ta e' s' and es "(shr s, xs)" ta es' s' arbitrary: e'' s'' xs and es'' s'' xs rule: red_reds.inducts)
case RedNew
thus ?case by(auto elim!: red_cases dest: deterministic_heap_ops_allocateD[OF det])
next
case RedNewArray
thus ?case by(auto elim!: red_cases dest: deterministic_heap_ops_allocateD[OF det])
next
case RedCall thus ?case
by(auto elim!: red_cases dest: sees_method_fun simp add: map_eq_append_conv)
next
case RedCallExternal thus ?case
by(auto elim!: red_cases dest: red_external_deterministic[OF det] simp add: final_thread.actions_ok_iff map_eq_append_conv dest: sees_method_fun)
next
case RedCallNull thus ?case by(auto elim!: red_cases dest: sees_method_fun simp add: map_eq_append_conv)
next
case CallThrowParams thus ?case
by(auto elim!: red_cases dest: sees_method_fun simp add: map_eq_append_conv append_eq_map_conv append_eq_append_conv2 reds_map_Val_Throw Cons_eq_append_conv append_eq_Cons_conv)
qed(fastforce elim!: red_cases reds_cases dest: deterministic_heap_ops_readD[OF det] deterministic_heap_ops_writeD[OF det] iff: reds_map_Val_Throw)+
lemma red_mthr_deterministic:
assumes det: "deterministic_heap_ops"
shows "red_mthr.deterministic P UNIV"
proof(rule red_mthr.determisticI)
fix s t x ta' x' m' ta'' x'' m''
assume "thr s t = ⌊(x, no_wait_locks)⌋"
and red: "mred P t (x, shr s) ta' (x', m')" "mred P t (x, shr s) ta'' (x'', m'')"
and aok: "red_mthr.actions_ok s t ta'" "red_mthr.actions_ok s t ta''"
moreover obtain e xs where [simp]: "x = (e, xs)" by(cases x)
moreover obtain e' xs' where [simp]: "x' = (e', xs')" by(cases x')
moreover obtain e'' xs'' where [simp]: "x'' = (e'', xs'')" by(cases x'')
ultimately have "extTA2J P,P,t ⊢ ⟨e,(shr s, xs)⟩ -ta'→ ⟨e',(m', xs')⟩"
and "extTA2J P,P,t ⊢ ⟨e,(shr s, xs)⟩ -ta''→ ⟨e'',(m'', xs'')⟩"
by simp_all
from red_deterministic[OF det this aok]
show "ta' = ta'' ∧ x' = x'' ∧ m' = m''" by simp
qed simp
end
end
Theory WellTypeRT
section ‹Runtime Well-typedness›
theory WellTypeRT
imports
WellType
JHeap
begin
context J_heap_base begin
inductive WTrt :: "'addr J_prog ⇒ 'heap ⇒ env ⇒ 'addr expr ⇒ ty ⇒ bool"
and WTrts :: "'addr J_prog ⇒ 'heap ⇒ env ⇒ 'addr expr list ⇒ ty list ⇒ bool"
for P :: "'addr J_prog" and h :: "'heap"
where
WTrtNew:
"is_class P C ⟹ WTrt P h E (new C) (Class C)"
| WTrtNewArray:
"⟦ WTrt P h E e Integer; is_type P (T⌊⌉) ⟧
⟹ WTrt P h E (newA T⌊e⌉) (T⌊⌉)"
| WTrtCast:
"⟦ WTrt P h E e T; is_type P U ⟧ ⟹ WTrt P h E (Cast U e) U"
| WTrtInstanceOf:
"⟦ WTrt P h E e T; is_type P U ⟧ ⟹ WTrt P h E (e instanceof U) Boolean"
| WTrtVal:
"typeof⇘h⇙ v = Some T ⟹ WTrt P h E (Val v) T"
| WTrtVar:
"E V = Some T ⟹ WTrt P h E (Var V) T"
| WTrtBinOp:
"⟦ WTrt P h E e1 T1; WTrt P h E e2 T2; P ⊢ T1«bop»T2 : T ⟧
⟹ WTrt P h E (e1 «bop» e2) T"
| WTrtLAss:
"⟦ E V = Some T; WTrt P h E e T'; P ⊢ T' ≤ T ⟧
⟹ WTrt P h E (V:=e) Void"
| WTrtAAcc:
"⟦ WTrt P h E a (T⌊⌉); WTrt P h E i Integer ⟧
⟹ WTrt P h E (a⌊i⌉) T"
| WTrtAAccNT:
"⟦ WTrt P h E a NT; WTrt P h E i Integer ⟧
⟹ WTrt P h E (a⌊i⌉) T"
| WTrtAAss:
"⟦ WTrt P h E a (T⌊⌉); WTrt P h E i Integer; WTrt P h E e T' ⟧
⟹ WTrt P h E (a⌊i⌉ := e) Void"
| WTrtAAssNT:
"⟦ WTrt P h E a NT; WTrt P h E i Integer; WTrt P h E e T' ⟧
⟹ WTrt P h E (a⌊i⌉ := e) Void"
| WTrtALength:
"WTrt P h E a (T⌊⌉) ⟹ WTrt P h E (a∙length) Integer"
| WTrtALengthNT:
"WTrt P h E a NT ⟹ WTrt P h E (a∙length) T"
| WTrtFAcc:
"⟦ WTrt P h E e U; class_type_of' U = ⌊C⌋; P ⊢ C has F:T (fm) in D ⟧ ⟹
WTrt P h E (e∙F{D}) T"
| WTrtFAccNT:
"WTrt P h E e NT ⟹ WTrt P h E (e∙F{D}) T"
| WTrtFAss:
"⟦ WTrt P h E e1 U; class_type_of' U = ⌊C⌋; P ⊢ C has F:T (fm) in D; WTrt P h E e2 T2; P ⊢ T2 ≤ T ⟧
⟹ WTrt P h E (e1∙F{D}:=e2) Void"
| WTrtFAssNT:
"⟦ WTrt P h E e1 NT; WTrt P h E e2 T2 ⟧
⟹ WTrt P h E (e1∙F{D}:=e2) Void"
| WTrtCAS:
"⟦ WTrt P h E e1 U; class_type_of' U = ⌊C⌋; P ⊢ C has F:T (fm) in D; volatile fm;
WTrt P h E e2 T2; P ⊢ T2 ≤ T; WTrt P h E e3 T3; P ⊢ T3 ≤ T ⟧
⟹ WTrt P h E (e1∙compareAndSwap(D∙F, e2, e3)) Boolean"
| WTrtCASNT:
"⟦ WTrt P h E e1 NT; WTrt P h E e2 T2; WTrt P h E e3 T3 ⟧
⟹ WTrt P h E (e1∙compareAndSwap(D∙F, e2, e3)) Boolean"
| WTrtCall:
"⟦ WTrt P h E e U; class_type_of' U = ⌊C⌋; P ⊢ C sees M:Ts → T = meth in D;
WTrts P h E es Ts'; P ⊢ Ts' [≤] Ts ⟧
⟹ WTrt P h E (e∙M(es)) T"
| WTrtCallNT:
"⟦ WTrt P h E e NT; WTrts P h E es Ts ⟧
⟹ WTrt P h E (e∙M(es)) T"
| WTrtBlock:
"⟦ WTrt P h (E(V↦T)) e T'; case vo of None ⇒ True | ⌊v⌋ ⇒ ∃T'. typeof⇘h⇙ v = ⌊T'⌋ ∧ P ⊢ T' ≤ T ⟧
⟹ WTrt P h E {V:T=vo; e} T'"
| WTrtSynchronized:
"⟦ WTrt P h E o' T; is_refT T; WTrt P h E e T' ⟧
⟹ WTrt P h E (sync(o') e) T'"
| WTrtInSynchronized:
"⟦ WTrt P h E (addr a) T; WTrt P h E e T' ⟧
⟹ WTrt P h E (insync(a) e) T'"
| WTrtSeq:
"⟦ WTrt P h E e1 T1; WTrt P h E e2 T2 ⟧
⟹ WTrt P h E (e1;;e2) T2"
| WTrtCond:
"⟦ WTrt P h E e Boolean; WTrt P h E e1 T1; WTrt P h E e2 T2; P ⊢ lub(T1, T2) = T ⟧
⟹ WTrt P h E (if (e) e1 else e2) T"
| WTrtWhile:
"⟦ WTrt P h E e Boolean; WTrt P h E c T ⟧
⟹ WTrt P h E (while(e) c) Void"
| WTrtThrow:
"⟦ WTrt P h E e T; P ⊢ T ≤ Class Throwable ⟧
⟹ WTrt P h E (throw e) T'"
| WTrtTry:
"⟦ WTrt P h E e1 T1; WTrt P h (E(V ↦ Class C)) e2 T2; P ⊢ T1 ≤ T2 ⟧
⟹ WTrt P h E (try e1 catch(C V) e2) T2"
| WTrtNil: "WTrts P h E [] []"
| WTrtCons: "⟦ WTrt P h E e T; WTrts P h E es Ts ⟧ ⟹ WTrts P h E (e # es) (T # Ts)"
abbreviation
WTrt_syntax :: "'addr J_prog ⇒ env ⇒ 'heap ⇒ 'addr expr ⇒ ty ⇒ bool" ("_,_,_ ⊢ _ : _" [51,51,51]50)
where
"P,E,h ⊢ e : T ≡ WTrt P h E e T"
abbreviation
WTrts_syntax :: "'addr J_prog ⇒ env ⇒ 'heap ⇒ 'addr expr list ⇒ ty list ⇒ bool" ("_,_,_ ⊢ _ [:] _" [51,51,51]50)
where
"P,E,h ⊢ es [:] Ts ≡ WTrts P h E es Ts"
lemmas [intro!] =
WTrtNew WTrtNewArray WTrtCast WTrtInstanceOf WTrtVal WTrtVar WTrtBinOp WTrtLAss
WTrtBlock WTrtSynchronized WTrtInSynchronized WTrtSeq WTrtCond WTrtWhile
WTrtThrow WTrtTry WTrtNil WTrtCons
lemmas [intro] =
WTrtFAcc WTrtFAccNT WTrtFAss WTrtFAssNT WTrtCall WTrtCallNT
WTrtAAcc WTrtAAccNT WTrtAAss WTrtAAssNT WTrtALength WTrtALengthNT
subsection‹Easy consequences›
inductive_simps WTrts_iffs [iff]:
"P,E,h ⊢ [] [:] Ts"
"P,E,h ⊢ e#es [:] T#Ts"
"P,E,h ⊢ (e#es) [:] Ts"
lemma WTrts_conv_list_all2: "P,E,h ⊢ es [:] Ts = list_all2 (WTrt P h E) es Ts"
by(induct es arbitrary: Ts)(auto simp add: list_all2_Cons1 elim: WTrts.cases)
lemma [simp]: "(P,E,h ⊢ es⇩1 @ es⇩2 [:] Ts) =
(∃Ts⇩1 Ts⇩2. Ts = Ts⇩1 @ Ts⇩2 ∧ P,E,h ⊢ es⇩1 [:] Ts⇩1 & P,E,h ⊢ es⇩2[:]Ts⇩2)"
by(auto simp add: WTrts_conv_list_all2 list_all2_append1 dest: list_all2_lengthD[symmetric])
inductive_simps WTrt_iffs [iff]:
"P,E,h ⊢ Val v : T"
"P,E,h ⊢ Var v : T"
"P,E,h ⊢ e⇩1;;e⇩2 : T⇩2"
"P,E,h ⊢ {V:T=vo; e} : T'"
inductive_cases WTrt_elim_cases[elim!]:
"P,E,h ⊢ newA T⌊i⌉ : U"
"P,E,h ⊢ v :=e : T"
"P,E,h ⊢ if (e) e⇩1 else e⇩2 : T"
"P,E,h ⊢ while(e) c : T"
"P,E,h ⊢ throw e : T"
"P,E,h ⊢ try e⇩1 catch(C V) e⇩2 : T"
"P,E,h ⊢ Cast D e : T"
"P,E,h ⊢ e instanceof U : T"
"P,E,h ⊢ a⌊i⌉ : T"
"P,E,h ⊢ a⌊i⌉ := e : T"
"P,E,h ⊢ a∙length : T"
"P,E,h ⊢ e∙F{D} : T"
"P,E,h ⊢ e∙F{D} := v : T"
"P,E,h ⊢ e∙compareAndSwap(D∙F, e2, e3) : T"
"P,E,h ⊢ e⇩1 «bop» e⇩2 : T"
"P,E,h ⊢ new C : T"
"P,E,h ⊢ e∙M(es) : T"
"P,E,h ⊢ sync(o') e : T"
"P,E,h ⊢ insync(a) e : T"
subsection‹Some interesting lemmas›
lemma WTrts_Val[simp]:
"P,E,h ⊢ map Val vs [:] Ts ⟷ map (typeof⇘h⇙) vs = map Some Ts"
by(induct vs arbitrary: Ts) auto
lemma WTrt_env_mono: "P,E,h ⊢ e : T ⟹ (⋀E'. E ⊆⇩m E' ⟹ P,E',h ⊢ e : T)"
and WTrts_env_mono: "P,E,h ⊢ es [:] Ts ⟹ (⋀E'. E ⊆⇩m E' ⟹ P,E',h ⊢ es [:] Ts)"
apply(induct rule: WTrt_WTrts.inducts)
apply(simp add: WTrtNew)
apply(fastforce simp: WTrtNewArray)
apply(fastforce simp: WTrtCast)
apply(fastforce simp: WTrtInstanceOf)
apply(fastforce simp: WTrtVal)
apply(simp add: WTrtVar map_le_def dom_def)
apply(fastforce simp add: WTrtBinOp)
apply(force simp: map_le_def)
apply(force simp: WTrtAAcc)
apply(force simp: WTrtAAccNT)
apply(rule WTrtAAss, fastforce, blast, blast)
apply(fastforce)
apply(rule WTrtALength, blast)
apply(blast)
apply(fastforce simp: WTrtFAcc)
apply(simp add: WTrtFAccNT)
apply(fastforce simp: WTrtFAss)
apply(fastforce simp: WTrtFAssNT)
apply(fastforce simp: WTrtCAS)
apply(fastforce simp: WTrtCASNT)
apply(fastforce simp: WTrtCall)
apply(fastforce simp: WTrtCallNT)
apply(fastforce simp: map_le_def)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce simp: WTrtSeq)
apply(fastforce simp: WTrtCond)
apply(fastforce simp: WTrtWhile)
apply(fastforce simp: WTrtThrow)
apply(auto simp: WTrtTry map_le_def dom_def)
done
lemma WT_implies_WTrt: "P,E ⊢ e :: T ⟹ P,E,h ⊢ e : T"
and WTs_implies_WTrts: "P,E ⊢ es [::] Ts ⟹ P,E,h ⊢ es [:] Ts"
apply(induct rule: WT_WTs.inducts)
apply fast
apply fast
apply fast
apply fast
apply(fastforce dest:typeof_lit_typeof)
apply(simp)
apply(fastforce intro: WT_binop_WTrt_binop)
apply(fastforce)
apply(erule WTrtAAcc)
apply(assumption)
apply(erule WTrtAAss)
apply(assumption)+
apply(erule WTrtALength)
apply(fastforce intro: has_visible_field)
apply(fastforce simp: WTrtFAss dest: has_visible_field)
apply(fastforce simp: WTrtCAS dest: has_visible_field)
apply(fastforce simp: WTrtCall)
apply(clarsimp simp del: fun_upd_apply, blast intro: typeof_lit_typeof)
apply(fastforce)+
done
lemma wt_blocks:
"⋀E. ⟦ length Vs = length Ts; length vs = length Ts ⟧ ⟹
(P,E,h ⊢ blocks Vs Ts vs e : T) =
(P,E(Vs[↦]Ts),h ⊢ e:T ∧ (∃Ts'. map (typeof⇘h⇙) vs = map Some Ts' ∧ P ⊢ Ts' [≤] Ts))"
apply(induct Vs Ts vs e rule:blocks.induct)
apply (force)
apply simp_all
done
end
context J_heap begin
lemma WTrt_hext_mono: "P,E,h ⊢ e : T ⟹ h ⊴ h' ⟹ P,E,h' ⊢ e : T"
and WTrts_hext_mono: "P,E,h ⊢ es [:] Ts ⟹ h ⊴ h' ⟹ P,E,h' ⊢ es [:] Ts"
apply(induct rule: WTrt_WTrts.inducts)
apply(simp add: WTrtNew)
apply(fastforce simp: WTrtNewArray)
apply(fastforce simp: WTrtCast)
apply(fastforce simp: WTrtInstanceOf)
apply(fastforce simp: WTrtVal dest:hext_typeof_mono)
apply(simp add: WTrtVar)
apply(fastforce simp add: WTrtBinOp)
apply(fastforce simp add: WTrtLAss)
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply(fast)
apply(simp add: WTrtFAccNT)
apply(fastforce simp: WTrtFAss del:WTrt_WTrts.intros WTrt_elim_cases)
apply(fastforce simp: WTrtFAssNT)
apply(fastforce simp: WTrtCAS)
apply(fastforce simp: WTrtCASNT)
apply(fastforce simp: WTrtCall)
apply(fastforce simp: WTrtCallNT)
apply(fastforce intro: hext_typeof_mono)
apply fastforce+
done
end
end
Theory Progress
section ‹Progress of Small Step Semantics›
theory Progress
imports
WellTypeRT
DefAss
SmallStep
"../Common/ExternalCallWF"
WWellForm
begin
context J_heap begin
lemma final_addrE [consumes 3, case_names addr Throw]:
"⟦ P,E,h ⊢ e : T; class_type_of' T = ⌊U⌋; final e;
⋀a. e = addr a ⟹ R;
⋀a. e = Throw a ⟹ R ⟧ ⟹ R"
apply(auto elim!: final.cases)
apply(case_tac v)
apply auto
done
lemma finalRefE [consumes 3, case_names null Class Array Throw]:
"⟦ P,E,h ⊢ e : T; is_refT T; final e;
e = null ⟹ R;
⋀a C. ⟦ e = addr a; T = Class C ⟧ ⟹ R;
⋀a U. ⟦ e = addr a; T = U⌊⌉ ⟧ ⟹ R;
⋀a. e = Throw a ⟹ R ⟧ ⟹ R"
apply(auto simp:final_iff)
apply(case_tac v)
apply(auto elim!: is_refT.cases)
done
end
theorem (in J_progress) red_progress:
assumes wf: "wwf_J_prog P" and hconf: "hconf h"
shows progress: "⟦ P,E,h ⊢ e : T; 𝒟 e ⌊dom l⌋; ¬ final e ⟧ ⟹ ∃e' s' ta. extTA,P,t ⊢ ⟨e,(h,l)⟩ -ta→ ⟨e',s'⟩"
and progresss: "⟦ P,E,h ⊢ es [:] Ts; 𝒟s es ⌊dom l⌋; ¬ finals es ⟧ ⟹ ∃es' s' ta. extTA,P,t ⊢ ⟨es,(h,l)⟩ [-ta→] ⟨es',s'⟩"
proof (induct arbitrary: l and l rule:WTrt_WTrts.inducts)
case (WTrtNew C)
thus ?case using WTrtNew
by(cases "allocate h (Class_type C) = {}")(fastforce intro: RedNewFail RedNew)+
next
case (WTrtNewArray E e T l)
have IH: "⋀l. ⟦𝒟 e ⌊dom l⌋; ¬ final e⟧ ⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨e,(h,l)⟩ -tas→ ⟨e', s'⟩"
and D: "𝒟 (newA T⌊e⌉) ⌊dom l⌋"
and ei: "P,E,h ⊢ e : Integer" by fact+
from D have De: "𝒟 e ⌊dom l⌋" by auto
show ?case
proof cases
assume "final e"
thus ?thesis
proof (rule finalE)
fix v
assume e [simp]: "e = Val v"
with ei have "typeof⇘h⇙ v = Some Integer" by fastforce
hence exei: "∃i. v = Intg i" by fastforce
then obtain i where v: "v = Intg i" by blast
thus ?thesis
proof (cases "0 <=s i")
case True
thus ?thesis using True ‹v = Intg i› WTrtNewArray.prems
by(cases "allocate h (Array_type T (nat (sint i))) = {}")(auto simp del: split_paired_Ex intro: RedNewArrayFail RedNewArray)
next
assume "¬ 0 <=s i"
hence "i <s 0" by simp
then have "extTA,P,t ⊢ ⟨newA T⌊Val(Intg i)⌉,(h, l)⟩ -ε→ ⟨THROW NegativeArraySize,(h, l)⟩"
by - (rule RedNewArrayNegative, auto)
with e v show ?thesis by blast
qed
next
fix exa
assume e: "e = Throw exa"
then have "extTA,P,t ⊢ ⟨newA T⌊Throw exa⌉,(h, l)⟩ -ε→ ⟨Throw exa,(h, l)⟩"
by - (rule NewArrayThrow)
with e show ?thesis by blast
qed
next
assume "¬ final e"
with IH De have exes: "∃e' s' ta. extTA,P,t ⊢ ⟨e,(h, l)⟩ -ta→ ⟨e',s'⟩" by simp
then obtain e' s' ta where "extTA,P,t ⊢ ⟨e,(h, l)⟩ -ta→ ⟨e',s'⟩" by blast
hence "extTA,P,t ⊢ ⟨newA T⌊e⌉,(h, l)⟩ -ta→ ⟨newA T⌊e'⌉,s'⟩" by - (rule NewArrayRed)
thus ?thesis by blast
qed
next
case (WTrtCast E e T U l)
have wte: "P,E,h ⊢ e : T"
and IH: "⋀l. ⟦𝒟 e ⌊dom l⌋; ¬ final e⟧
⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨e,(h,l)⟩ -tas→ ⟨e',s'⟩"
and D: "𝒟 (Cast U e) ⌊dom l⌋" by fact+
from D have De: "𝒟 e ⌊dom l⌋" by auto
show ?case
proof (cases "final e")
assume "final e"
thus ?thesis
proof (rule finalE)
fix v
assume ev: "e = Val v"
with WTrtCast obtain V where thvU: "typeof⇘h⇙ v = ⌊V⌋" by fastforce
thus ?thesis
proof (cases "P ⊢ V ≤ U")
assume "P ⊢ V ≤ U"
with thvU have "extTA,P,t ⊢ ⟨Cast U (Val v),(h, l)⟩ -ε→ ⟨Val v,(h,l)⟩"
by - (rule RedCast, auto)
with ev show ?thesis by blast
next
assume "¬ P ⊢ V ≤ U"
with thvU have "extTA,P,t ⊢ ⟨Cast U (Val v),(h, l)⟩ -ε→ ⟨THROW ClassCast,(h,l)⟩"
by - (rule RedCastFail, auto)
with ev show ?thesis by blast
qed
next
fix a
assume "e = Throw a"
thus ?thesis by(blast intro!:CastThrow)
qed
next
assume nf: "¬ final e"
from IH[OF De nf] show ?thesis by (blast intro:CastRed)
qed
next
case (WTrtInstanceOf E e T U l)
have wte: "P,E,h ⊢ e : T"
and IH: "⋀l. ⟦𝒟 e ⌊dom l⌋; ¬ final e⟧
⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨e,(h,l)⟩ -tas→ ⟨e',s'⟩"
and D: "𝒟 (e instanceof U) ⌊dom l⌋" by fact+
from D have De: "𝒟 e ⌊dom l⌋" by auto
show ?case
proof (cases "final e")
assume "final e"
thus ?thesis
proof (rule finalE)
fix v
assume ev: "e = Val v"
with WTrtInstanceOf obtain V where thvU: "typeof⇘h⇙ v = ⌊V⌋" by fastforce
hence "extTA,P,t ⊢ ⟨(Val v) instanceof U,(h, l)⟩ -ε→ ⟨Val (Bool (v ≠ Null ∧ P ⊢ V ≤ U)),(h,l)⟩"
by -(rule RedInstanceOf, auto)
with ev show ?thesis by blast
next
fix a
assume "e = Throw a"
thus ?thesis by(blast intro!:InstanceOfThrow)
qed
next
assume nf: "¬ final e"
from IH[OF De nf] show ?thesis by (blast intro:InstanceOfRed)
qed
next
case WTrtVal thus ?case by(simp add:final_iff)
next
case WTrtVar thus ?case by(fastforce intro:RedVar simp:hyper_isin_def)
next
case (WTrtBinOp E e1 T1 e2 T2 bop T)
show ?case
proof cases
assume "final e1"
thus ?thesis
proof (rule finalE)
fix v1 assume [simp]: "e1 = Val v1"
show ?thesis
proof cases
assume "final e2"
thus ?thesis
proof (rule finalE)
fix v2 assume [simp]: "e2 = Val v2"
with WTrtBinOp have type: "typeof⇘h⇙ v1 = ⌊T1⌋" "typeof⇘h⇙ v2 = ⌊T2⌋" by auto
from binop_progress[OF this ‹P ⊢ T1«bop»T2 : T›] obtain va
where "binop bop v1 v2 = ⌊va⌋" by blast
thus ?thesis by(cases va)(fastforce intro: RedBinOp RedBinOpFail)+
next
fix a assume "e2 = Throw a"
thus ?thesis by(fastforce intro:BinOpThrow2)
qed
next
assume "¬ final e2" with WTrtBinOp show ?thesis
by simp (fast intro!:BinOpRed2)
qed
next
fix a assume "e1 = Throw a"
thus ?thesis by simp (fast intro:BinOpThrow1)
qed
next
assume "¬ final e1" with WTrtBinOp show ?thesis
by simp (fast intro:BinOpRed1)
qed
next
case (WTrtLAss E V T e T')
show ?case
proof cases
assume "final e" with WTrtLAss show ?thesis
by(fastforce simp:final_iff intro!:RedLAss LAssThrow)
next
assume "¬ final e" with WTrtLAss show ?thesis
by simp (fast intro:LAssRed)
qed
next
case (WTrtAAcc E a T i l)
have wte: "P,E,h ⊢ a : T⌊⌉"
and wtei: "P,E,h ⊢ i : Integer"
and IHa: "⋀l. ⟦𝒟 a ⌊dom l⌋; ¬ final a⟧
⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨a,(h,l)⟩ -tas→ ⟨e',s'⟩"
and IHi: "⋀l. ⟦𝒟 i ⌊dom l⌋; ¬ final i⟧
⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨i,(h,l)⟩ -tas→ ⟨e',s'⟩"
and D: "𝒟 (a⌊i⌉) ⌊dom l⌋" by fact+
have ref: "is_refT (T⌊⌉)" by simp
from D have Da: "𝒟 a ⌊dom l⌋" by simp
show ?case
proof (cases "final a")
assume "final a"
with wte ref show ?case
proof (cases rule: finalRefE)
case null
thus ?thesis
proof (cases "final i")
assume "final i"
thus ?thesis
proof (rule finalE)
fix v
assume i: "i = Val v"
have "extTA,P,t ⊢ ⟨null⌊Val v⌉, (h, l)⟩ -ε→ ⟨THROW NullPointer, (h,l)⟩"
by(rule RedAAccNull)
with i null show ?thesis by blast
next
fix ex
assume i: "i = Throw ex"
have "extTA,P,t ⊢ ⟨null⌊Throw ex⌉, (h, l)⟩ -ε→ ⟨Throw ex, (h,l)⟩"
by(rule AAccThrow2)
with i null show ?thesis by blast
qed
next
assume "¬ final i"
from WTrtAAcc null show ?thesis
by simp
qed
next
case (Array ad U)
with wte obtain n where ty: "typeof_addr h ad = ⌊Array_type U n⌋" by auto
thus ?thesis
proof (cases "final i")
assume "final i"
thus ?thesis
proof(rule finalE)
fix v
assume [simp]: "i = Val v"
with wtei have "typeof⇘h⇙ v = Some Integer" by fastforce
hence "∃i. v = Intg i" by fastforce
then obtain i where [simp]: "v = Intg i" by blast
thus ?thesis
proof (cases "i <s 0 ∨ sint i ≥ int n")
case True
with WTrtAAcc Array ty show ?thesis by (fastforce intro: RedAAccBounds)
next
case False
then have "nat (sint i) < n"
by (simp add: not_le word_sless_alt nat_less_iff)
with ty have "P,h ⊢ ad@ACell (nat (sint i)) : U" by(auto intro!: addr_loc_type.intros)
from heap_read_total[OF hconf this]
obtain v where "heap_read h ad (ACell (nat (sint i))) v" by blast
with False Array ty show ?thesis by(fastforce intro: RedAAcc)
qed
next
fix ex
assume "i = Throw ex"
with WTrtAAcc Array show ?thesis by (fastforce intro: AAccThrow2)
qed
next
assume "¬ final i"
with WTrtAAcc Array show ?thesis by (fastforce intro: AAccRed2)
qed
next
fix ex
assume "a = Throw ex"
with WTrtAAcc show ?thesis by (fastforce intro: AAccThrow1)
qed simp
next
assume "¬ final a"
with WTrtAAcc show ?thesis by (fastforce intro: AAccRed1)
qed
next
case (WTrtAAccNT E a i T l)
have wte: "P,E,h ⊢ a : NT"
and wtei: "P,E,h ⊢ i : Integer"
and IHa: "⋀l. ⟦𝒟 a ⌊dom l⌋; ¬ final a⟧
⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨a,(h,l)⟩ -tas→ ⟨e',s'⟩"
and IHi: "⋀l. ⟦𝒟 i ⌊dom l⌋; ¬ final i⟧
⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨i,(h,l)⟩ -tas→ ⟨e',s'⟩" by fact+
have ref: "is_refT NT" by simp
with WTrtAAccNT have Da: "𝒟 a ⌊dom l⌋" by simp
thus ?case
proof (cases "final a")
case True
with wte ref show ?thesis
proof (cases rule: finalRefE)
case null
thus ?thesis
proof (cases "final i")
assume "final i"
thus ?thesis
proof (rule finalE)
fix v
assume i: "i = Val v"
have "extTA,P,t ⊢ ⟨null⌊Val v⌉, (h, l)⟩ -ε→ ⟨THROW NullPointer, (h,l)⟩"
by (rule RedAAccNull)
with WTrtAAccNT ‹final a› null ‹final i› i show ?thesis by blast
next
fix ex
assume i: "i = Throw ex"
have "extTA,P,t ⊢ ⟨null⌊Throw ex⌉, (h, l)⟩ -ε→ ⟨Throw ex, (h,l)⟩"
by(rule AAccThrow2)
with WTrtAAccNT ‹final a› null ‹final i› i show ?thesis by blast
qed
next
assume "¬ final i"
with WTrtAAccNT null show ?thesis
by(fastforce intro: AAccRed2)
qed
next
case Throw thus ?thesis by (fastforce intro: AAccThrow1)
qed simp_all
next
case False
with WTrtAAccNT Da show ?thesis by (fastforce intro:AAccRed1)
qed
next
case (WTrtAAss E a T i e T' l)
have wta: "P,E,h ⊢ a : T⌊⌉"
and wti: "P,E,h ⊢ i : Integer"
and wte: "P,E,h ⊢ e : T'"
and D: "𝒟 (a⌊i⌉ := e) ⌊dom l⌋"
and IH1: "⋀l. ⟦𝒟 a ⌊dom l⌋; ¬ final a⟧ ⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨a,(h, l)⟩ -tas→ ⟨e',s'⟩"
and IH2: "⋀l. ⟦𝒟 i ⌊dom l⌋; ¬ final i⟧ ⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨i,(h, l)⟩ -tas→ ⟨e',s'⟩"
and IH3: "⋀l. ⟦𝒟 e ⌊dom l⌋; ¬ final e⟧ ⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨e,(h, l)⟩ -tas→ ⟨e',s'⟩" by fact+
have ref: "is_refT (T⌊⌉)" by simp
show ?case
proof (cases "final a")
assume fa: "final a"
with wta ref show ?thesis
proof(cases rule: finalRefE)
case null
show ?thesis
proof(cases "final i")
assume "final i"
thus ?thesis
proof (rule finalE)
fix v
assume i: "i = Val v"
with wti have "typeof⇘h⇙ v = Some Integer" by fastforce
then obtain idx where "v = Intg idx" by fastforce
thus ?thesis
proof (cases "final e")
assume "final e"
thus ?thesis
proof (rule finalE)
fix w
assume "e = Val w"
with WTrtAAss null show ?thesis by (fastforce intro: RedAAssNull)
next
fix ex
assume "e = Throw ex"
with WTrtAAss null show ?thesis by (fastforce intro: AAssThrow3)
qed
next
assume "¬ final e"
with WTrtAAss null show ?thesis by (fastforce intro: AAssRed3)
qed
next
fix ex
assume "i = Throw ex"
with WTrtAAss null show ?thesis by (fastforce intro: AAssThrow2)
qed
next
assume "¬ final i"
with WTrtAAss null show ?thesis by (fastforce intro: AAssRed2)
qed
next
case (Array ad U)
with wta obtain n where ty: "typeof_addr h ad = ⌊Array_type U n⌋" by auto
thus ?thesis
proof (cases "final i")
assume fi: "final i"
thus ?thesis
proof (rule finalE)
fix v
assume ivalv: "i = Val v"
with wti have "typeof⇘h⇙ v = Some Integer" by fastforce
then obtain idx where vidx: "v = Intg idx" by fastforce
thus ?thesis
proof (cases "final e")
assume fe: "final e"
thus ?thesis
proof(rule finalE)
fix w
assume evalw: "e = Val w"
show ?thesis
proof(cases "idx <s 0 ∨ sint idx ≥ int n")
case True
with ty evalw Array ivalv vidx show ?thesis by(fastforce intro: RedAAssBounds)
next
case False
then have "nat (sint idx) < n"
by (simp add: not_le word_sless_alt nat_less_iff)
with ty have adal: "P,h ⊢ ad@ACell (nat (sint idx)) : U"
by(auto intro!: addr_loc_type.intros)
show ?thesis
proof(cases "P ⊢ T' ≤ U")
case True
with wte evalw have "P,h ⊢ w :≤ U"
by(auto simp add: conf_def)
from heap_write_total[OF hconf adal this]
obtain h' where h': "heap_write h ad (ACell (nat (sint idx))) w h'" ..
with ty False vidx ivalv evalw Array wte True
show ?thesis by(fastforce intro: RedAAss)
next
case False
with ty vidx ivalv evalw Array wte ‹¬ (idx <s 0 ∨ sint idx ≥ int n)›
show ?thesis by(fastforce intro: RedAAssStore)
qed
qed
next
fix ex
assume "e = Throw ex"
with Array ivalv show ?thesis by (fastforce intro: AAssThrow3)
qed
next
assume "¬ final e"
with WTrtAAss Array fi ivalv vidx show ?thesis by (fastforce intro: AAssRed3)
qed
next
fix ex
assume "i = Throw ex"
with WTrtAAss Array show ?thesis by (fastforce intro: AAssThrow2)
qed
next
assume "¬ final i"
with WTrtAAss Array show ?thesis by (fastforce intro: AAssRed2)
qed
next
fix ex
assume "a = Throw ex"
with WTrtAAss show ?thesis by (fastforce intro:AAssThrow1)
qed simp_all
next
assume "¬ final a"
with WTrtAAss show ?thesis by (fastforce intro: AAssRed1)
qed
next
case (WTrtAAssNT E a i e T' l)
have wta: "P,E,h ⊢ a : NT"
and wti: "P,E,h ⊢ i : Integer"
and wte: "P,E,h ⊢ e : T'"
and D: "𝒟 (a⌊i⌉ := e) ⌊dom l⌋"
and IH1: "⋀l. ⟦𝒟 a ⌊dom l⌋; ¬ final a⟧ ⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨a,(h, l)⟩ -tas→ ⟨e',s'⟩"
and IH2: "⋀l. ⟦𝒟 i ⌊dom l⌋; ¬ final i⟧ ⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨i,(h, l)⟩ -tas→ ⟨e',s'⟩"
and IH3: "⋀l. ⟦𝒟 e ⌊dom l⌋; ¬ final e⟧ ⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨e,(h, l)⟩ -tas→ ⟨e',s'⟩" by fact+
have ref: "is_refT NT" by simp
show ?case
proof (cases "final a")
assume fa: "final a"
show ?case
proof (cases "final i")
assume fi: "final i"
show ?case
proof (cases "final e")
assume fe: "final e"
with WTrtAAssNT fa fi show ?thesis
by (fastforce simp:final_iff intro: RedAAssNull AAssThrow1 AAssThrow2 AAssThrow3)
next
assume "¬ final e"
with WTrtAAssNT fa fi show ?thesis
by (fastforce simp: final_iff intro!:AAssRed3 AAssThrow1 AAssThrow2)
qed
next
assume "¬ final i"
with WTrtAAssNT fa show ?thesis
by (fastforce simp: final_iff intro!:AAssRed2 AAssThrow1)
qed
next
assume "¬ final a"
with WTrtAAssNT show ?thesis by (fastforce simp: final_iff intro!:AAssRed1)
qed
next
case (WTrtALength E a T l)
show ?case
proof(cases "final a")
case True
note wta = ‹P,E,h ⊢ a : T⌊⌉›
thus ?thesis
proof(rule finalRefE[OF _ _ True])
show "is_refT (T⌊⌉)" by simp
next
assume "a = null"
thus ?thesis by(fastforce intro: RedALengthNull)
next
fix ad U
assume "a = addr ad" and "T⌊⌉ = U⌊⌉"
with wta show ?thesis by(fastforce intro: RedALength)
next
fix ad
assume "a = Throw ad"
thus ?thesis by (fastforce intro: ALengthThrow)
qed simp
next
case False
from ‹𝒟 (a∙length) ⌊dom l⌋› have "𝒟 a ⌊dom l⌋" by simp
with False ‹⟦𝒟 a ⌊dom l⌋; ¬ final a⟧ ⟹ ∃e' s' ta. extTA,P,t ⊢ ⟨a,(h, l)⟩ -ta→ ⟨e',s'⟩›
obtain e' s' ta where "extTA,P,t ⊢ ⟨a,(h, l)⟩ -ta→ ⟨e',s'⟩" by blast
thus ?thesis by(blast intro: ALengthRed)
qed
next
case (WTrtALengthNT E a T l)
show ?case
proof(cases "final a")
case True
note wta = ‹P,E,h ⊢ a : NT›
thus ?thesis
proof(rule finalRefE[OF _ _ True])
show "is_refT NT" by simp
next
assume "a = null"
thus ?thesis by(blast intro: RedALengthNull)
next
fix ad
assume "a = Throw ad"
thus ?thesis by(blast intro: ALengthThrow)
qed simp_all
next
case False
from ‹𝒟 (a∙length) ⌊dom l⌋› have "𝒟 a ⌊dom l⌋" by simp
with False ‹⟦𝒟 a ⌊dom l⌋; ¬ final a⟧ ⟹ ∃e' s' ta. extTA,P,t ⊢ ⟨a,(h, l)⟩ -ta→ ⟨e',s'⟩›
obtain e' s' ta where "extTA,P,t ⊢ ⟨a,(h, l)⟩ -ta→ ⟨e',s'⟩" by blast
thus ?thesis by(blast intro: ALengthRed)
qed
next
case (WTrtFAcc E e U C F T fm D l)
have wte: "P,E,h ⊢ e : U"
and icto: "class_type_of' U = ⌊C⌋"
and field: "P ⊢ C has F:T (fm) in D" by fact+
show ?case
proof cases
assume "final e"
with wte icto show ?thesis
proof (cases rule: final_addrE)
case (addr a)
with wte obtain hU where ty: "typeof_addr h a = ⌊hU⌋" "U = ty_of_htype hU" by auto
with icto field have "P,h ⊢ a@CField D F : T" by(auto intro: addr_loc_type.intros)
from heap_read_total[OF hconf this]
obtain v where "heap_read h a (CField D F) v" by blast
with addr ty show ?thesis by(fastforce intro: RedFAcc)
next
fix a assume "e = Throw a"
thus ?thesis by(fastforce intro:FAccThrow)
qed
next
assume "¬ final e" with WTrtFAcc show ?thesis
by(fastforce intro!:FAccRed)
qed
next
case (WTrtFAccNT E e F D T l)
show ?case
proof cases
assume "final e"
with WTrtFAccNT show ?thesis
by(fastforce simp:final_iff intro: RedFAccNull FAccThrow)
next
assume "¬ final e"
with WTrtFAccNT show ?thesis by simp (fast intro:FAccRed)
qed
next
case (WTrtFAss E e1 U C F T fm D e2 T2 l)
have wte1: "P,E,h ⊢ e1 : U"
and icto: "class_type_of' U = ⌊C⌋"
and field: "P ⊢ C has F:T (fm) in D" by fact+
show ?case
proof cases
assume "final e1"
with wte1 icto show ?thesis
proof (rule final_addrE)
fix a assume e1: "e1 = addr a"
show ?thesis
proof cases
assume "final e2"
thus ?thesis
proof (rule finalE)
fix v assume e2: "e2 = Val v"
from wte1 field icto e1 have adal: "P,h ⊢ a@CField D F : T"
by(auto intro: addr_loc_type.intros)
from e2 ‹P ⊢ T2 ≤ T› ‹P,E,h ⊢ e2 : T2›
have "P,h ⊢ v :≤ T" by(auto simp add: conf_def)
from heap_write_total[OF hconf adal this] obtain h'
where "heap_write h a (CField D F) v h'" ..
with wte1 field e1 e2 show ?thesis
by(fastforce intro: RedFAss)
next
fix a assume "e2 = Throw a"
thus ?thesis using e1 by(fastforce intro:FAssThrow2)
qed
next
assume "¬ final e2" with WTrtFAss ‹final e1› e1 show ?thesis
by simp (fast intro!:FAssRed2)
qed
next
fix a assume "e1 = Throw a"
thus ?thesis by(fastforce intro:FAssThrow1)
qed
next
assume "¬ final e1" with WTrtFAss show ?thesis
by(simp del: split_paired_Ex)(blast intro!:FAssRed1)
qed
next
case (WTrtFAssNT E e⇩1 e⇩2 T⇩2 F D l)
show ?case
proof cases
assume "final e⇩1"
show ?thesis
proof cases
assume "final e⇩2"
with WTrtFAssNT ‹final e⇩1› show ?thesis
by(fastforce simp:final_iff intro: RedFAssNull FAssThrow1 FAssThrow2)
next
assume "¬ final e⇩2"
with WTrtFAssNT ‹final e⇩1› show ?thesis
by (fastforce simp:final_iff intro!:FAssRed2 FAssThrow1)
qed
next
assume "¬ final e⇩1"
with WTrtFAssNT show ?thesis by (fastforce intro:FAssRed1)
qed
next
case (WTrtCAS E e1 U C F T fm D e2 T2 e3 T3)
show ?case
proof(cases "final e1")
case e1: True
with WTrtCAS.hyps(1,3) show ?thesis
proof(rule final_addrE)
fix a
assume e1: "e1 = addr a"
with WTrtCAS.hyps(1) obtain hU
where ty: "typeof_addr h a = ⌊hU⌋" "U = ty_of_htype hU" by auto
with WTrtCAS.hyps(3,4) have adal: "P,h ⊢ a@CField D F : T" by(auto intro: addr_loc_type.intros)
from heap_read_total[OF hconf this]
obtain v where v: "heap_read h a (CField D F) v" by blast
show ?thesis
proof(cases "final e2")
case e2: True
show ?thesis
proof(cases "final e3")
case e3: True
consider (Val2) v2 where "e2 = Val v2" | (Throw2) a2 where "e2 = Throw a2"
using e2 by(auto simp add: final_iff)
then show ?thesis
proof(cases)
case Val2
consider (Succeed) v3 where "e3 = Val v3" "v2 = v"
| (Fail) v3 where "e3 = Val v3" "v2 ≠ v"
| (Throw3) a3 where "e3 = Throw a3"
using e3 by(auto simp add: final_iff)
then show ?thesis
proof cases
case Succeed
with WTrtCAS.hyps(9,11) adal have "P,h ⊢ v3 :≤ T" by(auto simp add: conf_def)
from heap_write_total[OF hconf adal this] obtain h'
where "heap_write h a (CField D F) v3 h'" ..
with Val2 e1 v Succeed show ?thesis
by(auto intro: RedCASSucceed simp del: split_paired_Ex)
next
case Fail
with Val2 e1 v show ?thesis
by(auto intro: RedCASFail simp del: split_paired_Ex)
next
case Throw3
then show ?thesis using e1 Val2 by(auto intro: CASThrow3 simp del: split_paired_Ex)
qed
next
case Throw2
then show ?thesis using e1 by(auto intro: CASThrow2 simp del: split_paired_Ex)
qed
next
case False
with WTrtCAS e1 e2 show ?thesis
by(fastforce simp del: split_paired_Ex simp add: final_iff intro: CASRed3 CASThrow2)
qed
next
case False
with WTrtCAS e1 show ?thesis
by(fastforce intro: CASRed2 CASThrow2 simp del: split_paired_Ex)
qed
qed(fastforce intro: CASThrow)
next
case False
then show ?thesis using WTrtCAS by(fastforce intro: CASRed1)
qed
next
case (WTrtCASNT E e1 e2 T2 e3 T3 D F)
note [simp del] = split_paired_Ex
show ?case
proof(cases "final e1")
case e1: True
show ?thesis
proof(cases "final e2")
case e2: True
show ?thesis
proof(cases "final e3")
case True
with e1 e2 WTrtCASNT show ?thesis
by(fastforce simp add: final_iff intro: CASNull CASThrow CASThrow2 CASThrow3)
next
case False
with e1 e2 WTrtCASNT show ?thesis
by(fastforce simp add: final_iff intro: CASRed3 CASThrow CASThrow2)
qed
next
case False
with e1 WTrtCASNT show ?thesis
by(fastforce simp add: final_iff intro: CASRed2 CASThrow)
qed
next
case False
with WTrtCASNT show ?thesis
by(fastforce simp add: final_iff intro: CASRed1)
qed
next
case (WTrtCall E e U C M Ts T meth D es Ts' l)
have wte: "P,E,h ⊢ e : U"
and icto: "class_type_of' U = ⌊C⌋" by fact+
have IHe: "⋀l. ⟦ 𝒟 e ⌊dom l⌋; ¬ final e ⟧
⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨e,(h, l)⟩ -tas→ ⟨e',s'⟩" by fact
have sees: "P ⊢ C sees M: Ts→T = meth in D" by fact
have wtes: "P,E,h ⊢ es [:] Ts'" by fact
have IHes: "⋀l. ⟦𝒟s es ⌊dom l⌋; ¬ finals es⟧ ⟹ ∃es' s' ta. extTA,P,t ⊢ ⟨es,(h, l)⟩ [-ta→] ⟨es',s'⟩" by fact
have subtype: "P ⊢ Ts' [≤] Ts" by fact
have dae: "𝒟 (e∙M(es)) ⌊dom l⌋" by fact
show ?case
proof(cases "final e")
assume fine: "final e"
with wte icto show ?thesis
proof (rule final_addrE)
fix a assume e_addr: "e = addr a"
show ?thesis
proof(cases "∃vs. es = map Val vs")
assume es: "∃vs. es = map Val vs"
from wte e_addr obtain hU where ha: "typeof_addr h a = ⌊hU⌋" "U = ty_of_htype hU" by(auto)
have "length es = length Ts'" using wtes by(auto simp add: WTrts_conv_list_all2 dest: list_all2_lengthD)
moreover from subtype have "length Ts' = length Ts" by(auto dest: list_all2_lengthD)
ultimately have esTs: "length es = length Ts" by(auto)
show ?thesis
proof(cases meth)
case (Some pnsbody)
with esTs e_addr ha sees subtype es sees_wf_mdecl[OF wf sees] icto
show ?thesis by(cases pnsbody) (fastforce intro!: RedCall simp:list_all2_iff wf_mdecl_def)
next
case None
with sees wf have "D∙M(Ts) :: T" by(auto intro: sees_wf_native)
moreover from es obtain vs where vs: "es = map Val vs" ..
with wtes have tyes: "map typeof⇘h⇙ vs = map Some Ts'" by simp
with ha ‹D∙M(Ts) :: T› icto sees None
have "P,h ⊢ a∙M(vs) : T" using subtype by(auto simp add: external_WT'_iff)
from external_call_progress[OF wf this hconf, of t] obtain ta va h'
where "P,t ⊢ ⟨a∙M(vs), h⟩ -ta→ext ⟨va, h'⟩" by blast
thus ?thesis using ha icto None sees vs e_addr
by(fastforce intro: RedCallExternal simp del: split_paired_Ex)
qed
next
assume "¬(∃vs. es = map Val vs)"
hence not_all_Val: "¬(∀e ∈ set es. ∃v. e = Val v)"
by(simp add:ex_map_conv)
let ?ves = "takeWhile (λe. ∃v. e = Val v) es"
let ?rest = "dropWhile (λe. ∃v. e = Val v) es"
let ?ex = "hd ?rest" let ?rst = "tl ?rest"
from not_all_Val have nonempty: "?rest ≠ []" by auto
hence es: "es = ?ves @ ?ex # ?rst" by simp
have "∀e ∈ set ?ves. ∃v. e = Val v" by(fastforce dest:set_takeWhileD)
then obtain vs where ves: "?ves = map Val vs"
using ex_map_conv by blast
show ?thesis
proof cases
assume "final ?ex"
moreover from nonempty have "¬(∃v. ?ex = Val v)"
by(auto simp:neq_Nil_conv simp del:dropWhile_eq_Nil_conv)
(simp add:dropWhile_eq_Cons_conv)
ultimately obtain b where ex_Throw: "?ex = Throw b"
by(fast elim!:finalE)
show ?thesis using e_addr es ex_Throw ves
by(fastforce intro:CallThrowParams)
next
assume not_fin: "¬ final ?ex"
have "finals es = finals(?ves @ ?ex # ?rst)" using es
by(rule arg_cong)
also have "… = finals(?ex # ?rst)" using ves by simp
finally have "finals es = finals(?ex # ?rst)" .
hence "¬ finals es" using not_finals_ConsI[OF not_fin] by blast
thus ?thesis using e_addr dae IHes by(fastforce intro!:CallParams)
qed
qed
next
fix a assume "e = Throw a"
thus ?thesis by(fast intro!:CallThrowObj)
qed
next
assume "¬ final e"
with WTrtCall show ?thesis by(simp del: split_paired_Ex)(blast intro!:CallObj)
qed
next
case (WTrtCallNT E e es Ts M T l)
have wte: "P,E,h ⊢ e : NT" by fact
have IHe: "⋀l. ⟦ 𝒟 e ⌊dom l⌋; ¬ final e ⟧
⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨e,(h, l)⟩ -tas→ ⟨e',s'⟩" by fact
have IHes: "⋀l. ⟦𝒟s es ⌊dom l⌋; ¬ finals es⟧ ⟹ ∃es' s' ta. extTA,P,t ⊢ ⟨es,(h, l)⟩ [-ta→] ⟨es',s'⟩" by fact
have wtes: "P,E,h ⊢ es [:] Ts" by fact
have dae: "𝒟 (e∙M(es)) ⌊dom l⌋" by fact
show ?case
proof(cases "final e")
assume "final e"
moreover
{ fix v assume "e = Val v"
hence "e = null" using WTrtCallNT by simp
have ?case
proof cases
assume "finals es"
moreover
{ fix vs assume "es = map Val vs"
with WTrtCallNT ‹e = null› ‹finals es› have ?thesis by(fastforce intro: RedCallNull) }
moreover
{ fix vs a es' assume "es = map Val vs @ Throw a # es'"
with WTrtCallNT ‹e = null› ‹finals es› have ?thesis by(fastforce intro: CallThrowParams) }
ultimately show ?thesis by(fastforce simp:finals_iff)
next
assume "¬ finals es"
with WTrtCallNT ‹e = null› show ?thesis by(fastforce intro: CallParams)
qed
}
moreover
{ fix a assume "e = Throw a"
with WTrtCallNT have ?case by(fastforce intro: CallThrowObj) }
ultimately show ?thesis by(fastforce simp:final_iff)
next
assume "¬ final e"
with WTrtCallNT show ?thesis by (fastforce intro:CallObj)
qed
next
case (WTrtBlock E V T e T' vo l)
have IH: "⋀l. ⟦𝒟 e ⌊dom l⌋; ¬ final e⟧
⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨e,(h,l)⟩ -tas→ ⟨e',s'⟩"
and D: "𝒟 {V:T=vo; e} ⌊dom l⌋" by fact+
show ?case
proof cases
assume "final e"
thus ?thesis
proof (rule finalE)
fix v assume "e = Val v" thus ?thesis by(fast intro:RedBlock)
next
fix a assume "e = Throw a"
thus ?thesis by(fast intro:BlockThrow)
qed
next
assume not_fin: "¬ final e"
from D have De: "𝒟 e ⌊dom(l(V:=vo))⌋" by(auto simp add:hyperset_defs)
from IH[OF De not_fin]
obtain h' l' e' tas where red: "extTA,P,t ⊢ ⟨e,(h,l(V:=vo))⟩ -tas→ ⟨e',(h',l')⟩"
by auto
thus ?thesis by(blast intro: BlockRed)
qed
next
case (WTrtSynchronized E o' T e T' l)
note wto = ‹P,E,h ⊢ o' : T›
note IHe = ‹⋀l. ⟦𝒟 e ⌊dom l⌋; ¬ final e ⟧ ⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨e,(h, l)⟩ -tas→ ⟨e',s'⟩›
note wte = ‹P,E,h ⊢ e : T'›
note IHo = ‹⋀l. ⟦𝒟 o' ⌊dom l⌋; ¬ final o' ⟧ ⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨o',(h, l)⟩ -tas→ ⟨e',s'⟩›
note refT = ‹is_refT T›
note dae = ‹𝒟 (sync(o') e) ⌊dom l⌋›
show ?case
proof(cases "final o'")
assume fino: "final o'"
thus ?thesis
proof (rule finalE)
fix v
assume oval: "o' = Val v"
with wto refT show ?thesis
proof(cases "v")
assume vnull: "v = Null"
with oval vnull show ?thesis
by(fastforce intro: SynchronizedNull)
next
fix ad
assume vaddr: "v = Addr ad"
thus ?thesis using oval
by(fastforce intro: LockSynchronized)
qed(auto elim: refTE)
next
fix a
assume othrow: "o' = Throw a"
thus ?thesis by(fastforce intro: SynchronizedThrow1)
qed
next
assume nfino: "¬ final o'"
with dae IHo show ?case by(fastforce intro: SynchronizedRed1)
qed
next
case (WTrtInSynchronized E a T e T' l)
show ?case
proof(cases "final e")
case True thus ?thesis
by(fastforce elim!: finalE intro: UnlockSynchronized SynchronizedThrow2)
next
case False
moreover from ‹𝒟 (insync(a) e) ⌊dom l⌋› have "𝒟 e ⌊dom l⌋" by simp
moreover note IHe = ‹⋀l. ⟦𝒟 e ⌊dom l⌋; ¬ final e⟧ ⟹ ∃e' s' tas. extTA,P,t ⊢ ⟨e,(h, l)⟩ -tas→ ⟨e',s'⟩›
ultimately show ?thesis by(fastforce intro: SynchronizedRed2)
qed
next
case (WTrtSeq E e1 T1 e2 T2 l)
show ?case
proof cases
assume "final e1"
thus ?thesis
by(fast elim:finalE intro:intro:RedSeq SeqThrow)
next
assume "¬ final e1" with WTrtSeq show ?thesis
by(simp del: split_paired_Ex)(blast intro!:SeqRed)
qed
next
case (WTrtCond E e e1 T1 e2 T2 T l)
have wt: "P,E,h ⊢ e : Boolean" by fact
show ?case
proof cases
assume "final e"
thus ?thesis
proof (rule finalE)
fix v assume val: "e = Val v"
then obtain b where v: "v = Bool b" using wt by auto
show ?thesis
proof (cases b)
case True with val v show ?thesis by(fastforce intro:RedCondT)
next
case False with val v show ?thesis by(fastforce intro:RedCondF)
qed
next
fix a assume "e = Throw a"
thus ?thesis by(fast intro:CondThrow)
qed
next
assume "¬ final e" with WTrtCond show ?thesis
by simp (fast intro:CondRed)
qed
next
case WTrtWhile show ?case by(fast intro:RedWhile)
next
case (WTrtThrow E e T T' l)
show ?case
proof cases
assume "final e"
thus ?thesis
proof(induct rule: finalE)
case (Val v)
with ‹P ⊢ T ≤ Class Throwable› ‹¬ final (throw e)› ‹P,E,h ⊢ e : T›
have "v = Null" by(cases v)(auto simp add: final_iff widen_Class)
thus ?thesis using Val by(fastforce intro: RedThrowNull)
next
case (Throw a)
thus ?thesis by(fastforce intro: ThrowThrow)
qed
next
assume "¬ final e"
with WTrtThrow show ?thesis by simp (blast intro:ThrowRed)
qed
next
case (WTrtTry E e1 T1 V C e2 T2 l)
have wt1: "P,E,h ⊢ e1 : T1" by fact
show ?case
proof cases
assume "final e1"
thus ?thesis
proof (rule finalE)
fix v assume "e1 = Val v"
thus ?thesis by(fast intro:RedTry)
next
fix a
assume e1_Throw: "e1 = Throw a"
with wt1 obtain D where ha: "typeof_addr h a = ⌊Class_type D⌋"
by(auto simp add: widen_Class)
thus ?thesis using e1_Throw
by(cases "P ⊢ D ≼⇧* C")(fastforce intro:RedTryCatch RedTryFail)+
qed
next
assume "¬ final e1"
with WTrtTry show ?thesis by simp (fast intro:TryRed)
qed
next
case WTrtNil thus ?case by simp
next
case (WTrtCons E e T es Ts)
have IHe: "⋀l. ⟦𝒟 e ⌊dom l⌋; ¬ final e⟧
⟹ ∃e' s' ta. extTA,P,t ⊢ ⟨e,(h,l)⟩ -ta→ ⟨e',s'⟩"
and IHes: "⋀l. ⟦𝒟s es ⌊dom l⌋; ¬ finals es⟧
⟹ ∃es' s' ta. extTA,P,t ⊢ ⟨es,(h,l)⟩ [-ta→] ⟨es',s'⟩"
and D: "𝒟s (e#es) ⌊dom l⌋" and not_fins: "¬ finals(e # es)" by fact+
have De: "𝒟 e ⌊dom l⌋" and Des: "𝒟s es (⌊dom l⌋ ⊔ 𝒜 e)"
using D by auto
show ?case
proof cases
assume "final e"
thus ?thesis
proof (rule finalE)
fix v assume e: "e = Val v"
hence Des': "𝒟s es ⌊dom l⌋" using De Des by auto
have not_fins_tl: "¬ finals es" using not_fins e by simp
show ?thesis using e IHes[OF Des' not_fins_tl]
by (blast intro!:ListRed2)
next
fix a assume "e = Throw a"
hence False using not_fins by simp
thus ?thesis ..
qed
next
assume "¬ final e"
with IHe[OF De] show ?thesis by(fast intro!:ListRed1)
qed
qed
end
Theory DefAssPreservation
section ‹Preservation of definite assignment›
theory DefAssPreservation
imports
DefAss
JWellForm
SmallStep
begin
text‹Preservation of definite assignment more complex and requires a
few lemmas first.›
lemma D_extRetJ [intro!]: "𝒟 e A ⟹ 𝒟 (extRet2J e va) A"
by(cases va) simp_all
lemma blocks_defass [iff]: "⋀A. ⟦ length Vs = length Ts; length vs = length Ts⟧ ⟹
𝒟 (blocks Vs Ts vs e) A = 𝒟 e (A ⊔ ⌊set Vs⌋)"
apply(induct Vs Ts vs e rule:blocks.induct)
apply(simp_all add:hyperset_defs)
done
context J_heap_base begin
lemma red_lA_incr: "extTA,P,t ⊢ ⟨e,s⟩ -ta→ ⟨e',s'⟩ ⟹ ⌊dom (lcl s)⌋ ⊔ 𝒜 e ⊑ ⌊dom (lcl s')⌋ ⊔ 𝒜 e'"
and reds_lA_incr: "extTA,P,t ⊢ ⟨es,s⟩ [-ta→] ⟨es',s'⟩ ⟹ ⌊dom (lcl s)⌋ ⊔ 𝒜s es ⊑ ⌊dom (lcl s')⌋ ⊔ 𝒜s es'"
apply(induct rule:red_reds.inducts)
apply(simp_all del:fun_upd_apply add:hyperset_defs)
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply(force split: if_split_asm)
apply blast
apply blast
apply blast
apply blast
apply blast
apply(blast dest: red_lcl_incr)
apply(blast dest: red_lcl_incr)
by blast+
end
text‹Now preservation of definite assignment.›
declare hyperUn_comm [simp del]
declare hyperUn_leftComm [simp del]
context J_heap_base begin
lemma assumes wf: "wf_J_prog P"
shows red_preserves_defass: "extTA,P,t ⊢ ⟨e,s⟩ -ta→ ⟨e',s'⟩ ⟹ 𝒟 e ⌊dom (lcl s)⌋ ⟹ 𝒟 e' ⌊dom (lcl s')⌋"
and reds_preserves_defass: "extTA,P,t ⊢ ⟨es,s⟩ [-ta→] ⟨es',s'⟩ ⟹ 𝒟s es ⌊dom (lcl s)⌋ ⟹ 𝒟s es' ⌊dom (lcl s')⌋"
proof (induction rule:red_reds.inducts)
case BinOpRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
case AAccRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
case AAssRed1 thus ?case by(auto intro: red_lA_incr sqUn_lem D_mono)
next
case AAssRed2 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
case FAssRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
case CASRed1 thus ?case by(auto intro: red_lA_incr sqUn_lem D_mono)
next
case CASRed2 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
case CallObj thus ?case by (auto elim!: Ds_mono[OF red_lA_incr])
next
case CallParams thus ?case by(auto elim!: Ds_mono[OF red_lA_incr])
next
case RedCall thus ?case by(auto dest!:sees_wf_mdecl[OF wf] simp:wf_mdecl_def elim!:D_mono')
next
case BlockRed thus ?case
by(auto simp:hyperset_defs elim!:D_mono' simp del:fun_upd_apply split: if_split_asm)
next
case SynchronizedRed1 thus ?case by(auto elim!: D_mono[OF red_lA_incr])
next
case SeqRed thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
case CondRed thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
case TryRed thus ?case
by (fastforce dest:red_lcl_incr intro:D_mono' simp:hyperset_defs)
next
case RedWhile thus ?case by(auto simp:hyperset_defs elim!:D_mono')
next
case ListRed1 thus ?case by (auto elim!: Ds_mono[OF red_lA_incr])
qed (auto simp:hyperset_defs)
end
end
Theory TypeSafe
section ‹Type Safety Proof›
theory TypeSafe
imports
Progress
DefAssPreservation
begin
subsection‹Basic preservation lemmas›
text‹First two easy preservation lemmas.›
theorem (in J_conf_read)
shows red_preserves_hconf:
"⟦ extTA,P,t ⊢ ⟨e,s⟩ -ta→ ⟨e',s'⟩; P,E,hp s ⊢ e : T; hconf (hp s) ⟧ ⟹ hconf (hp s')"
and reds_preserves_hconf:
"⟦ extTA,P,t ⊢ ⟨es,s⟩ [-ta→] ⟨es',s'⟩; P,E,hp s ⊢ es [:] Ts; hconf (hp s) ⟧ ⟹ hconf (hp s')"
proof (induct arbitrary: T E and Ts E rule: red_reds.inducts)
case RedNew thus ?case
by(auto intro: hconf_heap_ops_mono)
next
case RedNewFail thus ?case
by(auto intro: hconf_heap_ops_mono)
next
case RedNewArray thus ?case
by(auto intro: hconf_heap_ops_mono)
next
case RedNewArrayFail thus ?case
by(auto intro: hconf_heap_ops_mono)
next
case (RedAAss h a U n i v U' h' l)
from ‹sint i < int n› ‹0 <=s i›
have "nat (sint i) < n"
by (simp add: word_sle_eq nat_less_iff)
thus ?case using RedAAss
by(fastforce elim: hconf_heap_write_mono intro: addr_loc_type.intros simp add: conf_def)
next
case RedFAss thus ?case
by(fastforce elim: hconf_heap_write_mono intro: addr_loc_type.intros simp add: conf_def)
next
case RedCASSucceed thus ?case
by(fastforce elim: hconf_heap_write_mono intro: addr_loc_type.intros simp add: conf_def)
next
case (RedCallExternal s a U M Ts T' D vs ta va h' ta' e' s')
hence "P,hp s ⊢ a∙M(vs) : T"
by(fastforce simp add: external_WT'_iff dest: sees_method_fun)
with RedCallExternal show ?case by(auto dest: external_call_hconf)
qed auto
theorem (in J_heap) red_preserves_lconf:
"⟦ extTA,P,t ⊢ ⟨e,s⟩ -ta→ ⟨e',s'⟩; P,E,hp s ⊢ e:T; P,hp s ⊢ lcl s (:≤) E ⟧ ⟹ P,hp s' ⊢ lcl s' (:≤) E"
and reds_preserves_lconf:
"⟦ extTA,P,t ⊢ ⟨es,s⟩ [-ta→] ⟨es',s'⟩; P,E,hp s ⊢ es[:]Ts; P,hp s ⊢ lcl s (:≤) E ⟧ ⟹ P,hp s' ⊢ lcl s' (:≤) E"
proof(induct arbitrary: T E and Ts E rule:red_reds.inducts)
case RedNew thus ?case
by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
case RedNewFail thus ?case
by(auto intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
case RedNewArray thus ?case
by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
case RedNewArrayFail thus ?case
by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
case RedLAss thus ?case
by(fastforce elim: lconf_upd simp add: conf_def simp del: fun_upd_apply )
next
case RedAAss thus ?case
by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
case RedFAss thus ?case
by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
case RedCASSucceed thus ?case
by(fastforce intro:lconf_hext hext_heap_ops simp del: fun_upd_apply)
next
case (BlockRed e h x V vo ta e' h' x' T T' E)
note red = ‹extTA,P,t ⊢ ⟨e,(h, x(V := vo))⟩ -ta→ ⟨e',(h', x')⟩›
note IH = ‹⋀T E. ⟦P,E,hp (h, x(V := vo)) ⊢ e : T;
P,hp (h, x(V := vo)) ⊢ lcl (h, x(V := vo)) (:≤) E⟧
⟹ P,hp (h', x') ⊢ lcl (h', x') (:≤) E›
note wt = ‹P,E,hp (h, x) ⊢ {V:T=vo; e} : T'›
note lconf = ‹P,hp (h, x) ⊢ lcl (h, x) (:≤) E›
from lconf_hext[OF lconf[simplified] red_hext_incr[OF red, simplified]]
have "P,h' ⊢ x (:≤) E" .
moreover from wt have "P,E(V↦T),h ⊢ e : T'" by(cases vo, auto)
moreover from lconf wt have "P,h ⊢ x(V := vo) (:≤) E(V ↦ T)"
by(cases vo)(simp add: lconf_def,auto intro: lconf_upd2 simp add: conf_def)
ultimately have "P,h' ⊢ x' (:≤) E(V↦T)"
by(auto intro: IH[simplified])
with ‹P,h' ⊢ x (:≤) E› show ?case
by(auto simp add: lconf_def split: if_split_asm)
next
case (RedCallExternal s a U M Ts T' D vs ta va h' ta' e' s')
from ‹P,t ⊢ ⟨a∙M(vs),hp s⟩ -ta→ext ⟨va,h'⟩› have "hp s ⊴ h'" by(rule red_external_hext)
with ‹s' = (h', lcl s)› ‹P,hp s ⊢ lcl s (:≤) E› show ?case by(auto intro: lconf_hext)
qed auto
text‹Combining conformance of heap and local variables:›
definition (in J_heap_conf_base) sconf :: "env ⇒ ('addr, 'heap) Jstate ⇒ bool" ("_ ⊢ _ √" [51,51]50)
where "E ⊢ s √ ≡ let (h,l) = s in hconf h ∧ P,h ⊢ l (:≤) E ∧ preallocated h"
context J_conf_read begin
lemma red_preserves_sconf:
"⟦ extTA,P,t ⊢ ⟨e,s⟩ -tas→ ⟨e',s'⟩; P,E,hp s ⊢ e : T; E ⊢ s √ ⟧ ⟹ E ⊢ s' √"
apply(auto dest: red_preserves_hconf red_preserves_lconf simp add:sconf_def)
apply(fastforce dest: red_hext_incr intro: preallocated_hext)
done
lemma reds_preserves_sconf:
"⟦ extTA,P,t ⊢ ⟨es,s⟩ [-ta→] ⟨es',s'⟩; P,E,hp s ⊢ es [:] Ts; E ⊢ s √ ⟧ ⟹ E ⊢ s' √"
apply(auto dest: reds_preserves_hconf reds_preserves_lconf simp add: sconf_def)
apply(fastforce dest: reds_hext_incr intro: preallocated_hext)
done
end
lemma (in J_heap_base) wt_external_call:
"⟦ conf_extRet P h va T; P,E,h ⊢ e : T ⟧ ⟹ ∃T'. P,E,h ⊢ extRet2J e va : T' ∧ P ⊢ T' ≤ T"
by(cases va)(auto simp add: conf_def)
subsection "Subject reduction"
theorem (in J_conf_read) assumes wf: "wf_J_prog P"
shows subject_reduction:
"⟦ extTA,P,t ⊢ ⟨e,s⟩ -ta→ ⟨e',s'⟩; E ⊢ s √; P,E,hp s ⊢ e:T; P,hp s ⊢ t √t ⟧
⟹ ∃T'. P,E,hp s' ⊢ e':T' ∧ P ⊢ T' ≤ T"
and subjects_reduction:
"⟦ extTA,P,t ⊢ ⟨es,s⟩ [-ta→] ⟨es',s'⟩; E ⊢ s √; P,E,hp s ⊢ es[:]Ts; P,hp s ⊢ t √t ⟧
⟹ ∃Ts'. P,E,hp s' ⊢ es'[:]Ts' ∧ P ⊢ Ts' [≤] Ts"
proof (induct arbitrary: T E and Ts E rule:red_reds.inducts)
case RedNew
thus ?case by(auto dest: allocate_SomeD)
next
case RedNewFail thus ?case unfolding sconf_def
by(fastforce intro:typeof_OutOfMemory preallocated_heap_ops simp add: xcpt_subcls_Throwable[OF _ wf])
next
case NewArrayRed
thus ?case by fastforce
next
case RedNewArray
thus ?case by(auto dest: allocate_SomeD)
next
case RedNewArrayNegative thus ?case unfolding sconf_def
by(fastforce intro: preallocated_heap_ops simp add: xcpt_subcls_Throwable[OF _ wf])
next
case RedNewArrayFail thus ?case unfolding sconf_def
by(fastforce intro:typeof_OutOfMemory preallocated_heap_ops simp add: xcpt_subcls_Throwable[OF _ wf])
next
case (CastRed e s ta e' s' C T E)
have esse: "extTA,P,t ⊢ ⟨e,s⟩ -ta→ ⟨e',s'⟩"
and IH: "⋀T E. ⟦E ⊢ s √; P,E,hp s ⊢ e : T; P,hp s ⊢ t √t⟧ ⟹ ∃T'. P,E,hp s' ⊢ e' : T' ∧ P ⊢ T' ≤ T"
and hconf: "E ⊢ s √"
and wtc: "P,E,hp s ⊢ Cast C e : T" by fact+
thus ?case
proof(clarsimp)
fix T'
assume wte: "P,E,hp s ⊢ e : T'" "is_type P C"
from wte and hconf and IH and ‹P,hp s ⊢ t √t› have "∃U. P,E,hp s' ⊢ e' : U ∧ P ⊢ U ≤ T'" by simp
then obtain U where wtee: "P,E,hp s' ⊢ e' : U" and UsTT: "P ⊢ U ≤ T'" by blast
from wtee ‹is_type P C› have "P,E,hp s' ⊢ Cast C e' : C" by(rule WTrtCast)
thus "∃T'. P,E,hp s' ⊢ Cast C e' : T' ∧ P ⊢ T' ≤ C" by blast
qed
next
case RedCast thus ?case
by(clarsimp simp add: is_refT_def)
next
case RedCastFail thus ?case unfolding sconf_def
by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
case (InstanceOfRed e s ta e' s' U T E)
have IH: "⋀T E. ⟦E ⊢ s √; P,E,hp s ⊢ e : T; P,hp s ⊢ t √t⟧ ⟹ ∃T'. P,E,hp s' ⊢ e' : T' ∧ P ⊢ T' ≤ T"
and hconf: "E ⊢ s √"
and wtc: "P,E,hp s ⊢ e instanceof U : T"
and tconf: "P,hp s ⊢ t √t" by fact+
from wtc obtain T' where "P,E,hp s ⊢ e : T'" by auto
from IH[OF hconf this tconf] obtain T'' where "P,E,hp s' ⊢ e' : T''" by auto
with wtc show ?case by auto
next
case RedInstanceOf thus ?case
by(clarsimp)
next
case (BinOpRed1 e⇩1 s ta e⇩1' s' bop e⇩2 T E)
have red: "extTA,P,t ⊢ ⟨e⇩1, s⟩ -ta→ ⟨e⇩1', s'⟩"
and IH: "⋀T E. ⟦E ⊢ s √; P,E,hp s ⊢ e⇩1:T; P,hp s ⊢ t √t⟧
⟹ ∃U. P,E,hp s' ⊢ e⇩1' : U ∧ P ⊢ U ≤ T"
and conf: "E ⊢ s √" and wt: "P,E,hp s ⊢ e⇩1 «bop» e⇩2 : T"
and tconf: "P,hp s ⊢ t √t" by fact+
from wt obtain T1 T2 where wt1: "P,E,hp s ⊢ e⇩1 : T1"
and wt2: "P,E,hp s ⊢ e⇩2 : T2" and wtbop: "P ⊢ T1«bop»T2 : T" by auto
from IH[OF conf wt1 tconf] obtain T1' where wt1': "P,E,hp s' ⊢ e⇩1' : T1'"
and sub: "P ⊢ T1' ≤ T1" by blast
from WTrt_binop_widen_mono[OF wtbop sub widen_refl]
obtain T' where wtbop': "P ⊢ T1'«bop»T2 : T'" and sub': "P ⊢ T' ≤ T" by blast
from wt1' WTrt_hext_mono[OF wt2 red_hext_incr[OF red]] wtbop'
have "P,E,hp s' ⊢ e⇩1' «bop» e⇩2 : T'" by(rule WTrtBinOp)
with sub' show ?case by blast
next
case (BinOpRed2 e⇩2 s ta e⇩2' s' v⇩1 bop T E)
have red: "extTA,P,t ⊢ ⟨e⇩2,s⟩ -ta→ ⟨e⇩2',s'⟩" by fact
have IH: "⋀E T. ⟦E ⊢ s √; P,E,hp s ⊢ e⇩2:T; P,hp s ⊢ t √t⟧
⟹ ∃U. P,E,hp s' ⊢ e⇩2' : U ∧ P ⊢ U ≤ T"
and tconf: "P,hp s ⊢ t √t" by fact+
have conf: "E ⊢ s √" and wt: "P,E,hp s ⊢ (Val v⇩1) «bop» e⇩2 : T" by fact+
from wt obtain T1 T2 where wt1: "P,E,hp s ⊢ Val v⇩1 : T1"
and wt2: "P,E,hp s ⊢ e⇩2 : T2" and wtbop: "P ⊢ T1«bop»T2 : T" by auto
from IH[OF conf wt2 tconf] obtain T2' where wt2': "P,E,hp s' ⊢ e⇩2' : T2'"
and sub: "P ⊢ T2' ≤ T2" by blast
from WTrt_binop_widen_mono[OF wtbop widen_refl sub]
obtain T' where wtbop': "P ⊢ T1«bop»T2' : T'" and sub': "P ⊢ T' ≤ T" by blast
from WTrt_hext_mono[OF wt1 red_hext_incr[OF red]] wt2' wtbop'
have "P,E,hp s' ⊢ Val v⇩1 «bop» e⇩2' : T'" by(rule WTrtBinOp)
with sub' show ?case by blast
next
case (RedBinOp bop v1 v2 v s)
from ‹E ⊢ s √› have preh: "preallocated (hp s)" by(cases s)(simp add: sconf_def)
from ‹P,E,hp s ⊢ Val v1 «bop» Val v2 : T› obtain T1 T2
where "typeof⇘hp s⇙ v1 = ⌊T1⌋" "typeof⇘hp s⇙ v2 = ⌊T2⌋" "P ⊢ T1«bop»T2 : T" by auto
with wf preh have "P,hp s ⊢ v :≤ T" using ‹binop bop v1 v2 = ⌊Inl v⌋›
by(rule binop_type)
thus ?case by(auto simp add: conf_def)
next
case (RedBinOpFail bop v1 v2 a s)
from ‹E ⊢ s √› have preh: "preallocated (hp s)" by(cases s)(simp add: sconf_def)
from ‹P,E,hp s ⊢ Val v1 «bop» Val v2 : T› obtain T1 T2
where "typeof⇘hp s⇙ v1 = ⌊T1⌋" "typeof⇘hp s⇙ v2 = ⌊T2⌋" "P ⊢ T1«bop»T2 : T" by auto
with wf preh have "P,hp s ⊢ Addr a :≤ Class Throwable" using ‹binop bop v1 v2 = ⌊Inr a⌋›
by(rule binop_type)
thus ?case by(auto simp add: conf_def)
next
case RedVar thus ?case by (fastforce simp:sconf_def lconf_def conf_def)
next
case LAssRed thus ?case by(blast intro:widen_trans)
next
case RedLAss thus ?case by fastforce
next
case (AAccRed1 a s ta a' s' i T E)
have IH: "⋀E T. ⟦E ⊢ s √; P,E,hp s ⊢ a : T; P,hp s ⊢ t √t⟧ ⟹ ∃T'. P,E,hp s' ⊢ a' : T' ∧ P ⊢ T' ≤ T"
and assa: "extTA,P,t ⊢ ⟨a,s⟩ -ta→ ⟨a',s'⟩"
and wt: "P,E,hp s ⊢ a⌊i⌉ : T"
and hconf: "E ⊢ s √"
and tconf: "P,hp s ⊢ t √t" by fact+
from wt have wti: "P,E,hp s ⊢ i : Integer" by auto
from wti red_hext_incr[OF assa] have wti': "P,E,hp s' ⊢ i : Integer" by - (rule WTrt_hext_mono)
{ assume wta: "P,E,hp s ⊢ a : T⌊⌉"
from IH[OF hconf wta tconf]
obtain U where wta': "P,E,hp s' ⊢ a' : U" and UsubT: "P ⊢ U ≤ T⌊⌉" by fastforce
with wta' wti' have ?case by(cases U, auto simp add: widen_Array) }
moreover
{ assume wta: "P,E,hp s ⊢ a : NT"
from IH[OF hconf wta tconf] have "P,E,hp s' ⊢ a' : NT" by fastforce
from this wti' have ?case
by(fastforce intro:WTrtAAccNT) }
ultimately show ?case using wt by auto
next
case (AAccRed2 i s ta i' s' a T E)
have IH: "⋀E T. ⟦E ⊢ s √; P,E,hp s ⊢ i : T; P,hp s ⊢ t √t⟧ ⟹ ∃T'. P,E,hp s' ⊢ i' : T' ∧ P ⊢ T' ≤ T"
and issi: "extTA,P,t ⊢ ⟨i,s⟩ -ta→ ⟨i',s'⟩"
and wt: "P,E,hp s ⊢ Val a⌊i⌉ : T"
and sconf: "E ⊢ s √"
and tconf: "P,hp s ⊢ t √t" by fact+
from wt have wti: "P,E,hp s ⊢ i : Integer" by auto
from wti IH sconf tconf have wti': "P,E,hp s' ⊢ i' : Integer" by blast
from wt show ?case
proof (rule WTrt_elim_cases)
assume wta: "P,E,hp s ⊢ Val a : T⌊⌉"
from wta red_hext_incr[OF issi] have wta': "P,E,hp s' ⊢ Val a : T⌊⌉" by (rule WTrt_hext_mono)
from wta' wti' show ?case by(fastforce)
next
assume wta: "P,E,hp s ⊢ Val a : NT"
from wta red_hext_incr[OF issi] have wta': "P,E,hp s' ⊢ Val a : NT" by (rule WTrt_hext_mono)
from wta' wti' show ?case
by(fastforce elim:WTrtAAccNT)
qed
next
case RedAAccNull thus ?case unfolding sconf_def
by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
case RedAAccBounds thus ?case unfolding sconf_def
by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
case (RedAAcc h a T n i v l T' E)
from ‹E ⊢ (h, l) √› have "hconf h" by(clarsimp simp add: sconf_def)
from ‹0 <=s i› ‹sint i < int n›
have "nat (sint i) < n"
by (simp add: word_sle_eq nat_less_iff)
with ‹typeof_addr h a = ⌊Array_type T n⌋› have "P,h ⊢ a@ACell (nat (sint i)) : T"
by(auto intro: addr_loc_type.intros)
from heap_read_conf[OF ‹heap_read h a (ACell (nat (sint i))) v› this] ‹hconf h›
have "P,h ⊢ v :≤ T" by simp
thus ?case using RedAAcc by(auto simp add: conf_def)
next
case (AAssRed1 a s ta a' s' i e T E)
have IH: "⋀E T. ⟦E ⊢ s √; P,E,hp s ⊢ a : T; P,hp s ⊢ t √t⟧ ⟹ ∃T'. P,E,hp s' ⊢ a' : T' ∧ P ⊢ T' ≤ T"
and assa: "extTA,P,t ⊢ ⟨a,s⟩ -ta→ ⟨a',s'⟩"
and wt: "P,E,hp s ⊢ a⌊i⌉ := e : T"
and sconf: "E ⊢ s √"
and tconf: "P,hp s ⊢ t √t" by fact+
from wt have void: "T = Void" by blast
from wt have wti: "P,E,hp s ⊢ i : Integer" by auto
from wti red_hext_incr[OF assa] have wti': "P,E,hp s' ⊢ i : Integer" by - (rule WTrt_hext_mono)
{ assume wta: "P,E,hp s ⊢ a : NT"
from IH[OF sconf wta tconf] have wta': "P,E,hp s' ⊢ a' : NT" by fastforce
from wt wta obtain V where wte: "P,E,hp s ⊢ e : V" by(auto)
from wte red_hext_incr[OF assa] have wte': "P,E,hp s' ⊢ e : V" by - (rule WTrt_hext_mono)
from wta' wti' wte' void have ?case
by(fastforce elim: WTrtAAssNT) }
moreover
{ fix U
assume wta: "P,E,hp s ⊢ a : U⌊⌉"
from IH[OF sconf wta tconf]
obtain U' where wta': "P,E,hp s' ⊢ a' : U'" and UsubT: "P ⊢ U' ≤ U⌊⌉" by fastforce
with wta' have ?case
proof(cases U')
case NT
assume UNT: "U' = NT"
from UNT wt wta obtain V where wte: "P,E,hp s ⊢ e : V" by(auto)
from wte red_hext_incr[OF assa] have wte': "P,E,hp s' ⊢ e : V" by - (rule WTrt_hext_mono)
from wta' UNT wti' wte' void show ?thesis
by(fastforce elim: WTrtAAssNT)
next
case (Array A)
have UA: "U' = A⌊⌉" by fact
with UA UsubT wt wta obtain V where wte: "P,E,hp s ⊢ e : V" by auto
from wte red_hext_incr[OF assa] have wte': "P,E,hp s' ⊢ e : V" by - (rule WTrt_hext_mono)
with wta' wte' UA wti' void show ?thesis by (fast elim:WTrtAAss)
qed(simp_all add: widen_Array) }
ultimately show ?case using wt by blast
next
case (AAssRed2 i s ta i' s' a e T E)
have IH: "⋀E T. ⟦E ⊢ s √; P,E,hp s ⊢ i : T; P,hp s ⊢ t √t ⟧ ⟹ ∃T'. P,E,hp s' ⊢ i' : T' ∧ P ⊢ T' ≤ T"
and issi: "extTA,P,t ⊢ ⟨i,s⟩ -ta→ ⟨i',s'⟩"
and wt: "P,E,hp s ⊢ Val a⌊i⌉ := e : T"
and sconf: "E ⊢ s √" and tconf: "P,hp s ⊢ t √t" by fact+
from wt have void: "T = Void" by blast
from wt have wti: "P,E,hp s ⊢ i : Integer" by auto
from IH[OF sconf wti tconf] have wti': "P,E,hp s' ⊢ i' : Integer" by fastforce
from wt show ?case
proof(rule WTrt_elim_cases)
fix U T'
assume wta: "P,E,hp s ⊢ Val a : U⌊⌉"
and wte: "P,E,hp s ⊢ e : T'"
from wte red_hext_incr[OF issi] have wte': "P,E,hp s' ⊢ e : T'" by - (rule WTrt_hext_mono)
from wta red_hext_incr[OF issi] have wta': "P,E,hp s' ⊢ Val a : U⌊⌉" by - (rule WTrt_hext_mono)
from wta' wti' wte' void show ?case by (fastforce elim:WTrtAAss)
next
fix T'
assume wta: "P,E,hp s ⊢ Val a : NT"
and wte: "P,E,hp s ⊢ e : T'"
from wte red_hext_incr[OF issi] have wte': "P,E,hp s' ⊢ e : T'" by - (rule WTrt_hext_mono)
from wta red_hext_incr[OF issi] have wta': "P,E,hp s' ⊢ Val a : NT" by - (rule WTrt_hext_mono)
from wta' wti' wte' void show ?case by (fastforce elim:WTrtAAss)
qed
next
case (AAssRed3 e s ta e' s' a i T E)
have IH: "⋀E T. ⟦E ⊢ s √; P,E,hp s ⊢ e : T; P,hp s ⊢ t √t⟧ ⟹ ∃T'. P,E,hp s' ⊢ e' : T' ∧ P ⊢ T' ≤ T"
and issi: "extTA,P,t ⊢ ⟨e,s⟩ -ta→ ⟨e',s'⟩"
and wt: "P,E,hp s ⊢ Val a⌊Val i⌉ := e : T"
and sconf: "E ⊢ s √" and tconf: "P,hp s ⊢ t √t" by fact+
from wt have void: "T = Void" by blast
from wt have wti: "P,E,hp s ⊢ Val i : Integer" by auto
from wti red_hext_incr[OF issi] have wti': "P,E,hp s' ⊢ Val i : Integer" by - (rule WTrt_hext_mono)
from wt show ?case
proof(rule WTrt_elim_cases)
fix U T'
assume wta: "P,E,hp s ⊢ Val a : U⌊⌉"
and wte: "P,E,hp s ⊢ e : T'"
from wta red_hext_incr[OF issi] have wta': "P,E,hp s' ⊢ Val a : U⌊⌉" by - (rule WTrt_hext_mono)
from IH[OF sconf wte tconf]
obtain V where wte': "P,E,hp s' ⊢ e' : V" by fastforce
from wta' wti' wte' void show ?case by (fastforce elim:WTrtAAss)
next
fix T'
assume wta: "P,E,hp s ⊢ Val a : NT"
and wte: "P,E,hp s ⊢ e : T'"
from wta red_hext_incr[OF issi] have wta': "P,E,hp s' ⊢ Val a : NT" by - (rule WTrt_hext_mono)
from IH[OF sconf wte tconf]
obtain V where wte': "P,E,hp s' ⊢ e' : V" by fastforce
from wta' wti' wte' void show ?case by (fastforce elim:WTrtAAss)
qed
next
case RedAAssNull thus ?case unfolding sconf_def
by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
case RedAAssBounds thus ?case unfolding sconf_def
by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
case RedAAssStore thus ?case unfolding sconf_def
by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
case RedAAss thus ?case
by(auto simp del:fun_upd_apply)
next
case (ALengthRed a s ta a' s' T E)
note IH = ‹⋀T'. ⟦E ⊢ s √; P,E,hp s ⊢ a : T'; P,hp s ⊢ t √t⟧
⟹ ∃T''. P,E,hp s' ⊢ a' : T'' ∧ P ⊢ T'' ≤ T'›
from ‹P,E,hp s ⊢ a∙length : T›
show ?case
proof(rule WTrt_elim_cases)
fix T'
assume [simp]: "T = Integer"
and wta: "P,E,hp s ⊢ a : T'⌊⌉"
from wta ‹E ⊢ s √› IH ‹P,hp s ⊢ t √t›
obtain T'' where wta': "P,E,hp s' ⊢ a' : T''"
and sub: "P ⊢ T'' ≤ T'⌊⌉" by blast
from sub have "P,E,hp s' ⊢ a'∙length : Integer"
unfolding widen_Array
proof(rule disjE)
assume "T'' = NT"
with wta' show ?thesis by(auto)
next
assume "∃V. T'' = V⌊⌉ ∧ P ⊢ V ≤ T'"
then obtain V where "T'' = V⌊⌉" "P ⊢ V ≤ T'" by blast
with wta' show ?thesis by -(rule WTrtALength, simp)
qed
thus ?thesis by(simp)
next
assume "P,E,hp s ⊢ a : NT"
with ‹E ⊢ s √› IH ‹P,hp s ⊢ t √t›
obtain T'' where wta': "P,E,hp s' ⊢ a' : T''"
and sub: "P ⊢ T'' ≤ NT" by blast
from sub have "T'' = NT" by auto
with wta' show ?thesis by(auto)
qed
next
case (RedALength h a T n l T' E)
from ‹P,E,hp (h, l) ⊢ addr a∙length : T'› ‹typeof_addr h a = ⌊Array_type T n⌋›
have [simp]: "T' = Integer" by(auto)
thus ?case by(auto)
next
case RedALengthNull thus ?case unfolding sconf_def
by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
case (FAccRed e s ta e' s' F D T E)
have IH: "⋀E T. ⟦E ⊢ s √; P,E,hp s ⊢ e : T; P,hp s ⊢ t √t⟧
⟹ ∃U. P,E,hp s' ⊢ e' : U ∧ P ⊢ U ≤ T"
and conf: "E ⊢ s √" and wt: "P,E,hp s ⊢ e∙F{D} : T"
and tconf: "P,hp s ⊢ t √t" by fact+
{ fix T' C fm
assume wte: "P,E,hp s ⊢ e : T'"
and icto: "class_type_of' T' = ⌊C⌋"
and has: "P ⊢ C has F:T (fm) in D"
from IH[OF conf wte tconf]
obtain U where wte': "P,E,hp s' ⊢ e' : U" and UsubC: "P ⊢ U ≤ T'" by auto
with UsubC have ?case
proof(cases "U = NT")
case True
thus ?thesis using wte' by(blast intro:WTrtFAccNT widen_refl)
next
case False
with icto UsubC obtain C' where icto': "class_type_of' U = ⌊C'⌋"
and C'subC: "P ⊢ C' ≼⇧* C"
by(rule widen_is_class_type_of)
from has_field_mono[OF has C'subC] wte' icto'
show ?thesis by(auto intro!:WTrtFAcc)
qed }
moreover
{ assume "P,E,hp s ⊢ e : NT"
hence "P,E,hp s' ⊢ e' : NT" using IH[OF conf _ tconf] by fastforce
hence ?case by(fastforce intro:WTrtFAccNT widen_refl) }
ultimately show ?case using wt by blast
next
case RedFAcc thus ?case unfolding sconf_def
by(fastforce dest: heap_read_conf intro: addr_loc_type.intros simp add: conf_def)
next
case RedFAccNull thus ?case unfolding sconf_def
by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
case (FAssRed1 e s ta e' s' F D e⇩2)
have red: "extTA,P,t ⊢ ⟨e,s⟩ -ta→ ⟨e',s'⟩"
and IH: "⋀E T. ⟦E ⊢ s √; P,E,hp s ⊢ e : T; P,hp s ⊢ t √t⟧
⟹ ∃U. P,E,hp s' ⊢ e' : U ∧ P ⊢ U ≤ T"
and conf: "E ⊢ s √" and wt: "P,E,hp s ⊢ e∙F{D}:=e⇩2 : T"
and tconf: "P,hp s ⊢ t √t" by fact+
from wt have void: "T = Void" by blast
{ assume "P,E,hp s ⊢ e : NT"
hence "P,E,hp s' ⊢ e' : NT" using IH[OF conf _ tconf] by fastforce
moreover obtain T⇩2 where "P,E,hp s ⊢ e⇩2 : T⇩2" using wt by auto
from this red_hext_incr[OF red] have "P,E,hp s' ⊢ e⇩2 : T⇩2"
by(rule WTrt_hext_mono)
ultimately have ?case using void by(blast intro!:WTrtFAssNT)
}
moreover
{ fix T' C TF T⇩2 fm
assume wt⇩1: "P,E,hp s ⊢ e : T'" and icto: "class_type_of' T' = ⌊C⌋" and wt⇩2: "P,E,hp s ⊢ e⇩2 : T⇩2"
and has: "P ⊢ C has F:TF (fm) in D" and sub: "P ⊢ T⇩2 ≤ TF"
obtain U where wt⇩1': "P,E,hp s' ⊢ e' : U" and UsubC: "P ⊢ U ≤ T'"
using IH[OF conf wt⇩1 tconf] by blast
have wt⇩2': "P,E,hp s' ⊢ e⇩2 : T⇩2"
by(rule WTrt_hext_mono[OF wt⇩2 red_hext_incr[OF red]])
have ?case
proof(cases "U = NT")
case True
with wt⇩1' wt⇩2' void show ?thesis by(blast intro!:WTrtFAssNT)
next
case False
with icto UsubC obtain C' where icto': "class_type_of' U = ⌊C'⌋"
and "subclass": "P ⊢ C' ≼⇧* C" by(rule widen_is_class_type_of)
have "P ⊢ C' has F:TF (fm) in D" by(rule has_field_mono[OF has "subclass"])
with wt⇩1' show ?thesis using wt⇩2' sub void icto' by(blast intro:WTrtFAss)
qed }
ultimately show ?case using wt by blast
next
case (FAssRed2 e⇩2 s ta e⇩2' s' v F D T E)
have red: "extTA,P,t ⊢ ⟨e⇩2,s⟩ -ta→ ⟨e⇩2',s'⟩"
and IH: "⋀E T. ⟦E ⊢ s √; P,E,hp s ⊢ e⇩2 : T; P,hp s ⊢ t √t⟧
⟹ ∃U. P,E,hp s' ⊢ e⇩2' : U ∧ P ⊢ U ≤ T"
and conf: "E ⊢ s √" and wt: "P,E,hp s ⊢ Val v∙F{D}:=e⇩2 : T"
and tconf: "P,hp s ⊢ t √t" by fact+
from wt have [simp]: "T = Void" by auto
from wt show ?case
proof (rule WTrt_elim_cases)
fix U C TF T⇩2 fm
assume wt⇩1: "P,E,hp s ⊢ Val v : U"
and icto: "class_type_of' U = ⌊C⌋"
and has: "P ⊢ C has F:TF (fm) in D"
and wt⇩2: "P,E,hp s ⊢ e⇩2 : T⇩2" and TsubTF: "P ⊢ T⇩2 ≤ TF"
have wt⇩1': "P,E,hp s' ⊢ Val v : U"
by(rule WTrt_hext_mono[OF wt⇩1 red_hext_incr[OF red]])
obtain T⇩2' where wt⇩2': "P,E,hp s' ⊢ e⇩2' : T⇩2'" and T'subT: "P ⊢ T⇩2' ≤ T⇩2"
using IH[OF conf wt⇩2 tconf] by blast
have "P,E,hp s' ⊢ Val v∙F{D}:=e⇩2' : Void"
by(rule WTrtFAss[OF wt⇩1' icto has wt⇩2' widen_trans[OF T'subT TsubTF]])
thus ?case by auto
next
fix T⇩2 assume null: "P,E,hp s ⊢ Val v : NT" and wt⇩2: "P,E,hp s ⊢ e⇩2 : T⇩2"
from null have "v = Null" by simp
moreover
obtain T⇩2' where "P,E,hp s' ⊢ e⇩2' : T⇩2' ∧ P ⊢ T⇩2' ≤ T⇩2"
using IH[OF conf wt⇩2 tconf] by blast
ultimately show ?thesis by(fastforce intro:WTrtFAssNT)
qed
next
case RedFAss thus ?case by(auto simp del:fun_upd_apply)
next
case RedFAssNull thus ?case unfolding sconf_def
by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
case (CASRed1 e s ta e' s' D F e2 e3)
from CASRed1.prems(2) consider (NT) T2 T3 where
"P,E,hp s ⊢ e : NT" "T = Boolean" "P,E,hp s ⊢ e2 : T2" "P,E,hp s ⊢ e3 : T3"
| (RefT) U T' C fm T2 T3 where
"P,E,hp s ⊢ e : U" "T = Boolean" "class_type_of' U = ⌊C⌋" "P ⊢ C has F:T' (fm) in D"
"P,E,hp s ⊢ e2 : T2" "P ⊢ T2 ≤ T'" "P,E,hp s ⊢ e3 : T3" "P ⊢ T3 ≤ T'" "volatile fm" by fastforce
thus ?case
proof cases
case NT
have "P,E,hp s' ⊢ e' : NT" using CASRed1.hyps(2)[OF CASRed1.prems(1) NT(1) CASRed1.prems(3)] by auto
moreover from NT CASRed1.hyps(1)[THEN red_hext_incr]
have "P,E,hp s' ⊢ e2 : T2" "P,E,hp s' ⊢ e3 : T3" by(auto intro: WTrt_hext_mono)
ultimately show ?thesis using NT by(auto intro: WTrtCASNT)
next
case RefT
from CASRed1.hyps(2)[OF CASRed1.prems(1) RefT(1) CASRed1.prems(3)]
obtain U' where wt1: "P,E,hp s' ⊢ e' : U'" "P ⊢ U' ≤ U" by blast
from RefT CASRed1.hyps(1)[THEN red_hext_incr]
have wt2: "P,E,hp s' ⊢ e2 : T2" and wt3: "P,E,hp s' ⊢ e3 : T3" by(auto intro: WTrt_hext_mono)
show ?thesis
proof(cases "U' = NT")
case True
with RefT wt1 wt2 wt3 show ?thesis by(auto intro: WTrtCASNT)
next
case False
with RefT(3) wt1 obtain C' where icto': "class_type_of' U' = ⌊C'⌋"
and "subclass": "P ⊢ C' ≼⇧* C" by(blast intro: widen_is_class_type_of)
have "P ⊢ C' has F:T' (fm) in D" by(rule has_field_mono[OF RefT(4) "subclass"])
with RefT wt1 wt2 wt3 icto' show ?thesis by(auto intro!: WTrtCAS)
qed
qed
next
case (CASRed2 e s ta e' s' v D F e3)
consider (Null) "v = Null" | (Val) U C T' fm T2 T3 where
"class_type_of' U = ⌊C⌋" "P ⊢ C has F:T' (fm) in D" "volatile fm"
"P,E,hp s ⊢ e : T2" "P ⊢ T2 ≤ T'" "P,E,hp s ⊢ e3 : T3" "P ⊢ T3 ≤ T'" "T = Boolean"
"typeof⇘hp s⇙ v = ⌊U⌋" using CASRed2.prems(2) by auto
then show ?case
proof cases
case Null
then show ?thesis using CASRed2
by(force dest: red_hext_incr intro: WTrt_hext_mono WTrtCASNT)
next
case Val
from CASRed2.hyps(1) have hext: "hp s ⊴ hp s'" by(auto dest: red_hext_incr)
with Val(9) have "typeof⇘hp s'⇙ v = ⌊U⌋" by(rule type_of_hext_type_of)
moreover from CASRed2.hyps(2)[OF CASRed2.prems(1) Val(4) CASRed2.prems(3)] Val(5)
obtain T2' where "P,E,hp s' ⊢ e' : T2'" "P ⊢ T2' ≤ T'" by(auto intro: widen_trans)
moreover from Val(6) hext have "P,E,hp s' ⊢ e3 : T3" by(rule WTrt_hext_mono)
ultimately show ?thesis using Val by(auto intro: WTrtCAS)
qed
next
case (CASRed3 e s ta e' s' v D F v')
consider (Null) "v = Null" | (Val) U C T' fm T2 T3 where
"T = Boolean" "class_type_of' U = ⌊C⌋" "P ⊢ C has F:T' (fm) in D" "volatile fm"
"P ⊢ T2 ≤ T'" "P,E,hp s ⊢ e : T3" "P ⊢ T3 ≤ T'"
"typeof⇘hp s⇙ v = ⌊U⌋" "typeof⇘hp s⇙ v' = ⌊T2⌋"
using CASRed3.prems(2) by auto
then show ?case
proof cases
case Null
then show ?thesis using CASRed3
by(force dest: red_hext_incr intro: type_of_hext_type_of WTrtCASNT)
next
case Val
from CASRed3.hyps(1) have hext: "hp s ⊴ hp s'" by(auto dest: red_hext_incr)
with Val(8,9) have "typeof⇘hp s'⇙ v = ⌊U⌋" "typeof⇘hp s'⇙ v' = ⌊T2⌋"
by(blast intro: type_of_hext_type_of)+
moreover from CASRed3.hyps(2)[OF CASRed3.prems(1) Val(6) CASRed3.prems(3)] Val(7)
obtain T3' where "P,E,hp s' ⊢ e' : T3'" "P ⊢ T3' ≤ T'" by(auto intro: widen_trans)
ultimately show ?thesis using Val by(auto intro: WTrtCAS)
qed
next
case CASNull thus ?case unfolding sconf_def
by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
case (CallObj e s ta e' s' M es T E)
have red: "extTA,P,t ⊢ ⟨e,s⟩ -ta→ ⟨e',s'⟩"
and IH: "⋀E T. ⟦E ⊢ s √; P,E,hp s ⊢ e : T; P,hp s ⊢ t √t⟧
⟹ ∃U. P,E,hp s' ⊢ e' : U ∧ P ⊢ U ≤ T"
and conf: "E ⊢ s √" and wt: "P,E,hp s ⊢ e∙M(es) : T"
and tconf: "P,hp s ⊢ t √t" by fact+
from wt show ?case
proof(rule WTrt_elim_cases)
fix T' C Ts meth D Us
assume wte: "P,E,hp s ⊢ e : T'" and icto: "class_type_of' T' = ⌊C⌋"
and "method": "P ⊢ C sees M:Ts→T = meth in D"
and wtes: "P,E,hp s ⊢ es [:] Us" and subs: "P ⊢ Us [≤] Ts"
obtain U where wte': "P,E,hp s' ⊢ e' : U" and UsubC: "P ⊢ U ≤ T'"
using IH[OF conf wte tconf] by blast
show ?thesis
proof(cases "U = NT")
case True
moreover have "P,E,hp s' ⊢ es [:] Us"
by(rule WTrts_hext_mono[OF wtes red_hext_incr[OF red]])
ultimately show ?thesis using wte' by(blast intro!:WTrtCallNT)
next
case False
with icto UsubC obtain C'
where icto': "class_type_of' U = ⌊C'⌋" and "subclass": "P ⊢ C' ≼⇧* C"
by(rule widen_is_class_type_of)
obtain Ts' T' meth' D'
where method': "P ⊢ C' sees M:Ts'→T' = meth' in D'"
and subs': "P ⊢ Ts [≤] Ts'" and sub': "P ⊢ T' ≤ T"
using Call_lemma[OF "method" "subclass" wf] by fast
have wtes': "P,E,hp s' ⊢ es [:] Us"
by(rule WTrts_hext_mono[OF wtes red_hext_incr[OF red]])
show ?thesis using wtes' wte' icto' subs method' subs' sub' by(blast intro:widens_trans)
qed
next
fix Ts
assume "P,E,hp s ⊢ e:NT"
hence "P,E,hp s' ⊢ e' : NT" using IH[OF conf _ tconf] by fastforce
moreover
fix Ts assume wtes: "P,E,hp s ⊢ es [:] Ts"
have "P,E,hp s' ⊢ es [:] Ts"
by(rule WTrts_hext_mono[OF wtes red_hext_incr[OF red]])
ultimately show ?thesis by(blast intro!:WTrtCallNT)
qed
next
case (CallParams es s ta es' s' v M T E)
have reds: "extTA,P,t ⊢ ⟨es,s⟩ [-ta→] ⟨es',s'⟩"
and IH: "⋀Ts E. ⟦E ⊢ s √; P,E,hp s ⊢ es [:] Ts; P,hp s ⊢ t √t⟧
⟹ ∃Ts'. P,E,hp s' ⊢ es' [:] Ts' ∧ P ⊢ Ts' [≤] Ts"
and conf: "E ⊢ s √" and wt: "P,E,hp s ⊢ Val v∙M(es) : T"
and tconf: "P,hp s ⊢ t √t" by fact+
from wt show ?case
proof (rule WTrt_elim_cases)
fix U C Ts meth D Us
assume wte: "P,E,hp s ⊢ Val v : U" and icto: "class_type_of' U = ⌊C⌋"
and "P ⊢ C sees M:Ts→T = meth in D"
and wtes: "P,E,hp s ⊢ es [:] Us" and "P ⊢ Us [≤] Ts"
moreover have "P,E,hp s' ⊢ Val v : U"
by(rule WTrt_hext_mono[OF wte reds_hext_incr[OF reds]])
moreover obtain Us' where "P,E,hp s' ⊢ es' [:] Us'" "P ⊢ Us' [≤] Us"
using IH[OF conf wtes tconf] by blast
ultimately show ?thesis by(fastforce intro:WTrtCall widens_trans)
next
fix Us
assume null: "P,E,hp s ⊢ Val v : NT" and wtes: "P,E,hp s ⊢ es [:] Us"
from null have "v = Null" by simp
moreover
obtain Us' where "P,E,hp s' ⊢ es' [:] Us' ∧ P ⊢ Us' [≤] Us"
using IH[OF conf wtes tconf] by blast
ultimately show ?thesis by(fastforce intro:WTrtCallNT)
qed
next
case (RedCall s a U M Ts T pns body D vs T' E)
have hp: "typeof_addr (hp s) a = ⌊U⌋"
and "method": "P ⊢ class_type_of U sees M: Ts→T = ⌊(pns,body)⌋ in D"
and wt: "P,E,hp s ⊢ addr a∙M(map Val vs) : T'" by fact+
obtain Ts' where wtes: "P,E,hp s ⊢ map Val vs [:] Ts'"
and subs: "P ⊢ Ts' [≤] Ts" and T'isT: "T' = T"
using wt "method" hp wf by(auto 4 3 dest: sees_method_fun)
from wtes subs have length_vs: "length vs = length Ts"
by(auto simp add: WTrts_conv_list_all2 dest!: list_all2_lengthD)
have UsubD: "P ⊢ ty_of_htype U ≤ Class (class_type_of U)"
by(cases U)(simp_all add: widen_array_object)
from sees_wf_mdecl[OF wf "method"] obtain T''
where wtabody: "P,[this#pns [↦] Class D#Ts] ⊢ body :: T''"
and T''subT: "P ⊢ T'' ≤ T" and length_pns: "length pns = length Ts"
by(fastforce simp:wf_mdecl_def simp del:map_upds_twist)
from wtabody have "P,Map.empty(this#pns [↦] Class D#Ts),hp s ⊢ body : T''"
by(rule WT_implies_WTrt)
hence "P,E(this#pns [↦] Class D#Ts),hp s ⊢ body : T''"
by(rule WTrt_env_mono) simp
hence "P,E,hp s ⊢ blocks (this#pns) (Class D#Ts) (Addr a#vs) body : T''"
using wtes subs hp sees_method_decl_above[OF "method"] length_vs length_pns UsubD
by(auto simp add:wt_blocks rel_list_all2_Cons2 intro: widen_trans)
with T''subT T'isT show ?case by blast
next
case (RedCallExternal s a U M Ts T' D vs ta va h' ta' e' s')
from ‹P,t ⊢ ⟨a∙M(vs),hp s⟩ -ta→ext ⟨va,h'⟩› have "hp s ⊴ h'" by(rule red_external_hext)
with ‹P,E,hp s ⊢ addr a∙M(map Val vs) : T›
have "P,E,h' ⊢ addr a∙M(map Val vs) : T" by(rule WTrt_hext_mono)
moreover from ‹typeof_addr (hp s) a = ⌊U⌋› ‹P ⊢ class_type_of U sees M: Ts→T' = Native in D› ‹P,E,hp s ⊢ addr a∙M(map Val vs) : T›
have "P,hp s ⊢ a∙M(vs) : T'"
by(fastforce simp add: external_WT'_iff dest: sees_method_fun)
ultimately show ?case using RedCallExternal
by(auto 4 3 intro: red_external_conf_extRet[OF wf] intro!: wt_external_call simp add: sconf_def dest: sees_method_fun[where C="class_type_of U"])
next
case RedCallNull thus ?case unfolding sconf_def
by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
case (BlockRed e h x V vo ta e' h' x' T T' E)
note IH = ‹⋀T E. ⟦E ⊢ (h, x(V := vo)) √; P,E,hp (h, x(V := vo)) ⊢ e : T; P,hp (h, x(V := vo)) ⊢ t √t⟧
⟹ ∃T'. P,E,hp (h', x') ⊢ e' : T' ∧ P ⊢ T' ≤ T›[simplified]
from ‹P,E,hp (h, x) ⊢ {V:T=vo; e} : T'› have "P,E(V↦T),h ⊢ e : T'" by(cases vo, auto)
moreover from ‹E ⊢ (h, x) √› ‹P,E,hp (h, x) ⊢ {V:T=vo; e} : T'›
have "(E(V ↦ T)) ⊢ (h, x(V := vo)) √"
by(cases vo)(simp add: lconf_def sconf_def,auto simp add: sconf_def conf_def intro: lconf_upd2)
ultimately obtain T'' where wt': "P,E(V↦T),h' ⊢ e' : T''" "P ⊢ T'' ≤ T'" using ‹P,hp (h, x) ⊢ t √t›
by(auto dest: IH)
{ fix v
assume vo: "x' V = ⌊v⌋"
from ‹(E(V ↦ T)) ⊢ (h, x(V := vo)) √› ‹extTA,P,t ⊢ ⟨e,(h, x(V := vo))⟩ -ta→ ⟨e',(h', x')⟩› ‹P,E(V↦T),h ⊢ e : T'›
have "P,h' ⊢ x' (:≤) (E(V ↦ T))" by(auto simp add: sconf_def dest: red_preserves_lconf)
with vo have "∃T'. typeof⇘h'⇙ v = ⌊T'⌋ ∧ P ⊢ T' ≤ T" by(fastforce simp add: sconf_def lconf_def conf_def)
then obtain T' where "typeof⇘h'⇙ v = ⌊T'⌋" "P ⊢ T' ≤ T" by blast
hence ?case using wt' vo by(auto) }
moreover
{ assume "x' V = None" with wt' have ?case by(auto) }
ultimately show ?case by blast
next
case RedBlock thus ?case by auto
next
case (SynchronizedRed1 o' s ta o'' s' e T E)
have red: "extTA,P,t ⊢ ⟨o',s⟩ -ta→ ⟨o'',s'⟩" by fact
have IH: "⋀T E. ⟦E ⊢ s √; P,E,hp s ⊢ o' : T; P,hp s ⊢ t √t⟧ ⟹ ∃T'. P,E,hp s' ⊢ o'' : T' ∧ P ⊢ T' ≤ T" by fact
have conf: "E ⊢ s √" by fact
have wt: "P,E,hp s ⊢ sync(o') e : T" by fact+
thus ?case
proof(rule WTrt_elim_cases)
fix To
assume wto: "P,E,hp s ⊢ o' : To"
and refT: "is_refT To"
and wte: "P,E,hp s ⊢ e : T"
from IH[OF conf wto ‹P,hp s ⊢ t √t›] obtain To' where "P,E,hp s' ⊢ o'' : To'" and sub: "P ⊢ To' ≤ To" by auto
moreover have "P,E,hp s' ⊢ e : T"
by(rule WTrt_hext_mono[OF wte red_hext_incr[OF red]])
moreover have "is_refT To'" using refT sub by(auto intro: widen_refT)
ultimately show ?thesis by(auto)
qed
next
case SynchronizedNull thus ?case unfolding sconf_def
by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
case LockSynchronized thus ?case by(auto)
next
case (SynchronizedRed2 e s ta e' s' a T E)
have red: "extTA,P,t ⊢ ⟨e,s⟩ -ta→ ⟨e',s'⟩" by fact
have IH: "⋀T E. ⟦E ⊢ s √; P,E,hp s ⊢ e : T; P,hp s ⊢ t √t⟧ ⟹ ∃T'. P,E,hp s' ⊢ e' : T' ∧ P ⊢ T' ≤ T" by fact
have conf: "E ⊢ s √" by fact
have wt: "P,E,hp s ⊢ insync(a) e : T" by fact
thus ?case
proof(rule WTrt_elim_cases)
fix Ta
assume "P,E,hp s ⊢ e : T"
and hpa: "typeof_addr (hp s) a = ⌊Ta⌋"
from ‹P,E,hp s ⊢ e : T› conf ‹P,hp s ⊢ t √t› obtain T'
where "P,E,hp s' ⊢ e' : T'" "P ⊢ T' ≤ T" by(blast dest: IH)
moreover from red have hext: "hp s ⊴ hp s'" by(auto dest: red_hext_incr)
with hpa have "P,E,hp s' ⊢ addr a : ty_of_htype Ta"
by(auto intro: typeof_addr_hext_mono)
ultimately show ?thesis by auto
qed
next
case UnlockSynchronized thus ?case by(auto)
next
case SeqRed thus ?case
apply(auto)
apply(drule WTrt_hext_mono[OF _ red_hext_incr], assumption)
by auto
next
case (CondRed b s ta b' s' e1 e2 T E)
have red: "extTA,P,t ⊢ ⟨b,s⟩ -ta→ ⟨b',s'⟩" by fact
have IH: "⋀T E. ⟦E ⊢ s √; P,E,hp s ⊢ b : T; P,hp s ⊢ t √t⟧ ⟹ ∃T'. P,E,hp s' ⊢ b' : T' ∧ P ⊢ T' ≤ T" by fact
have conf: "E ⊢ s √" by fact
have wt: "P,E,hp s ⊢ if (b) e1 else e2 : T" by fact
thus ?case
proof(rule WTrt_elim_cases)
fix T1 T2
assume wtb: "P,E,hp s ⊢ b : Boolean"
and wte1: "P,E,hp s ⊢ e1 : T1"
and wte2: "P,E,hp s ⊢ e2 : T2"
and lub: "P ⊢ lub(T1, T2) = T"
from IH[OF conf wtb ‹P,hp s ⊢ t √t›] have "P,E,hp s' ⊢ b' : Boolean" by(auto)
moreover have "P,E,hp s' ⊢ e1 : T1"
by(rule WTrt_hext_mono[OF wte1 red_hext_incr[OF red]])
moreover have "P,E,hp s' ⊢ e2 : T2"
by(rule WTrt_hext_mono[OF wte2 red_hext_incr[OF red]])
ultimately show ?thesis using lub by auto
qed
next
case (ThrowRed e s ta e' s' T E)
have IH: "⋀T E. ⟦E ⊢ s √; P,E,hp s ⊢ e : T; P,hp s ⊢ t √t⟧ ⟹ ∃T'. P,E,hp s' ⊢ e' : T' ∧ P ⊢ T' ≤ T" by fact
have conf: "E ⊢ s √" by fact
have wt: "P,E,hp s ⊢ throw e : T" by fact
then obtain T'
where wte: "P,E,hp s ⊢ e : T'"
and nobject: "P ⊢ T' ≤ Class Throwable" by auto
from IH[OF conf wte ‹P,hp s ⊢ t √t›] obtain T''
where wte': "P,E,hp s' ⊢ e' : T''"
and PT'T'': "P ⊢ T'' ≤ T'" by blast
from nobject PT'T'' have "P ⊢ T'' ≤ Class Throwable"
by(auto simp add: widen_Class)(erule notE, rule rtranclp_trans)
hence "P,E,hp s' ⊢ throw e' : T" using wte' PT'T''
by -(erule WTrtThrow)
thus ?case by(auto)
next
case RedThrowNull thus ?case unfolding sconf_def
by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
case (TryRed e s ta e' s' C V e2 T E)
have red: "extTA,P,t ⊢ ⟨e,s⟩ -ta→ ⟨e',s'⟩" by fact
have IH: "⋀T E. ⟦E ⊢ s √; P,E,hp s ⊢ e : T; P,hp s ⊢ t √t⟧ ⟹ ∃T'. P,E,hp s' ⊢ e' : T' ∧ P ⊢ T' ≤ T" by fact
have conf: "E ⊢ s √" by fact
have wt: "P,E,hp s ⊢ try e catch(C V) e2 : T" by fact
thus ?case
proof(rule WTrt_elim_cases)
fix T1
assume wte: "P,E,hp s ⊢ e : T1"
and wte2: "P,E(V ↦ Class C),hp s ⊢ e2 : T"
and sub: "P ⊢ T1 ≤ T"
from IH[OF conf wte ‹P,hp s ⊢ t √t›] obtain T1' where "P,E,hp s' ⊢ e' : T1'" and "P ⊢ T1' ≤ T1" by(auto)
moreover have "P,E(V ↦ Class C),hp s' ⊢ e2 : T"
by(rule WTrt_hext_mono[OF wte2 red_hext_incr[OF red]])
ultimately show ?thesis using sub by(auto elim: widen_trans)
qed
next
case RedTryFail thus ?case unfolding sconf_def
by(fastforce simp add: xcpt_subcls_Throwable[OF _ wf])
next
case RedSeq thus ?case by auto
next
case RedCondT thus ?case by(auto dest: is_lub_upper)
next
case RedCondF thus ?case by(auto dest: is_lub_upper)
next
case RedWhile thus ?case by(fastforce)
next
case RedTry thus ?case by auto
next
case RedTryCatch thus ?case by(fastforce)
next
case (ListRed1 e s ta e' s' es Ts E)
note IH = ‹⋀T E. ⟦E ⊢ s √; P,E,hp s ⊢ e : T; P,hp s ⊢ t √t⟧ ⟹ ∃T'. P,E,hp s' ⊢ e' : T' ∧ P ⊢ T' ≤ T›
from ‹P,E,hp s ⊢ e # es [:] Ts› obtain T Ts' where "Ts = T # Ts'" "P,E,hp s ⊢ e : T" "P,E,hp s ⊢ es [:] Ts'" by auto
with IH[of E T] ‹E ⊢ s √› WTrts_hext_mono[OF ‹P,E,hp s ⊢ es [:] Ts'› red_hext_incr[OF ‹extTA,P,t ⊢ ⟨e,s⟩ -ta→ ⟨e',s'⟩›]]
show ?case using ‹P,hp s ⊢ t √t› by(auto simp add: list_all2_Cons2 intro: widens_refl)
next
case ListRed2 thus ?case
by(fastforce dest: hext_typeof_mono[OF reds_hext_incr])
qed(fastforce)+
end
Theory ProgressThreaded
section ‹Progress and type safety theorem for the multithreaded system›
theory ProgressThreaded
imports
Threaded
TypeSafe
"../Framework/FWProgress"
begin
lemma lock_ok_ls_Some_ex_ts_not_final:
assumes lock: "lock_ok ls ts"
and hl: "has_lock (ls $ l) t"
shows "∃e x ln. ts t = ⌊((e, x), ln)⌋ ∧ ¬ final e"
proof -
from lock have "lock_thread_ok ls ts"
by(rule lock_ok_lock_thread_ok)
with hl obtain e x ln
where tst: "ts t = ⌊((e, x), ln)⌋"
by(auto dest!: lock_thread_okD)
{ assume "final e"
hence "expr_locks e l = 0" by(rule final_locks)
with lock tst have "has_locks (ls $ l) t = 0"
by(auto dest: lock_okD2[rule_format, where l=l])
with hl have False by simp }
with tst show ?thesis by auto
qed
subsection ‹Preservation lemmata›
subsection ‹Definite assignment›
abbreviation
def_ass_ts_ok :: "('addr,'thread_id,'addr expr × 'addr locals) thread_info ⇒ 'heap ⇒ bool"
where
"def_ass_ts_ok ≡ ts_ok (λt (e, x) h. 𝒟 e ⌊dom x⌋)"
context J_heap_base begin
lemma assumes wf: "wf_J_prog P"
shows red_def_ass_new_thread:
"⟦ P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; NewThread t'' (e'', x'') c'' ∈ set ⦃ta⦄⇘t⇙ ⟧ ⟹ 𝒟 e'' ⌊dom x''⌋"
and reds_def_ass_new_thread:
"⟦ P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; NewThread t'' (e'', x'') c'' ∈ set ⦃ta⦄⇘t⇙ ⟧ ⟹ 𝒟 e'' ⌊dom x''⌋"
proof(induct rule: red_reds.inducts)
case (RedCallExternal s a T M vs ta va h' ta' e' s')
then obtain C fs a where subThread: "P ⊢ C ≼⇧* Thread" and ext: "extNTA2J P (C, run, a) = (e'', x'')"
by(fastforce dest: red_external_new_thread_sub_thread)
from sub_Thread_sees_run[OF wf subThread] obtain D pns body
where sees: "P ⊢ C sees run: []→Void = ⌊(pns, body)⌋ in D" by auto
from sees_wf_mdecl[OF wf this] have "𝒟 body ⌊{this}⌋"
by(auto simp add: wf_mdecl_def)
with sees ext show ?case by(clarsimp simp del: fun_upd_apply)
qed(auto simp add: ta_upd_simps)
lemma lifting_wf_def_ass: "wf_J_prog P ⟹ lifting_wf final_expr (mred P) (λt (e, x) m. 𝒟 e ⌊dom x⌋)"
apply(unfold_locales)
apply(auto dest: red_preserves_defass red_def_ass_new_thread)
done
lemma def_ass_ts_ok_J_start_state:
"⟦ wf_J_prog P; P ⊢ C sees M:Ts→T = ⌊(pns, body)⌋ in D; length vs = length Ts ⟧ ⟹
def_ass_ts_ok (thr (J_start_state P C M vs)) h"
apply(rule ts_okI)
apply(drule (1) sees_wf_mdecl)
apply(clarsimp simp add: wf_mdecl_def start_state_def split: if_split_asm)
done
end
subsection ‹typeability›
context J_heap_base begin
definition type_ok :: "'addr J_prog ⇒ env × ty ⇒ 'addr expr ⇒ 'heap ⇒ bool"
where "type_ok P ≡ (λ(E, T) e c. (∃T'. (P,E,c ⊢ e : T' ∧ P ⊢ T' ≤ T)))"
definition J_sconf_type_ET_start :: "'m prog ⇒ cname ⇒ mname ⇒ ('thread_id ⇀ (env × ty))"
where
"J_sconf_type_ET_start P C M ≡
let (_, _, T, _) = method P C M
in ([start_tid ↦ (Map.empty, T)])"
lemma fixes E :: env
assumes wf: "wf_J_prog P"
shows red_type_newthread:
"⟦ P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; P,E,hp s ⊢ e : T; NewThread t'' (e'', x'') (hp s') ∈ set ⦃ta⦄⇘t⇙ ⟧
⟹ ∃E T. P,E,hp s' ⊢ e'' : T ∧ P,hp s' ⊢ x'' (:≤) E"
and reds_type_newthread:
"⟦ P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; NewThread t'' (e'', x'') (hp s') ∈ set ⦃ta⦄⇘t⇙; P,E,hp s ⊢ es [:] Ts ⟧
⟹ ∃E T. P,E,hp s' ⊢ e'' : T ∧ P,hp s' ⊢ x'' (:≤) E"
proof(induct arbitrary: E T and E Ts rule: red_reds.inducts)
case (RedCallExternal s a U M Ts T' D vs ta va h' ta' e' s')
from ‹NewThread t'' (e'', x'') (hp s') ∈ set ⦃ta'⦄⇘t⇙› ‹ta' = extTA2J P ta›
obtain C' M' a' where nt: "NewThread t'' (C', M', a') (hp s') ∈ set ⦃ta⦄⇘t⇙"
and "extNTA2J P (C', M', a') = (e'', x'')" by fastforce
from red_external_new_thread_sees[OF wf ‹P,t ⊢ ⟨a∙M(vs),hp s⟩ -ta→ext ⟨va,h'⟩› nt] ‹typeof_addr (hp s) a = ⌊U⌋›
obtain T pns body D where h'a': "typeof_addr h' a' = ⌊Class_type C'⌋"
and sees: " P ⊢ C' sees M': []→T = ⌊(pns, body)⌋ in D" by auto
from sees_wf_mdecl[OF wf sees] obtain T where "P,[this ↦ Class D] ⊢ body :: T"
by(auto simp add: wf_mdecl_def)
hence "WTrt P (hp s') [this ↦ Class D] body T" by(rule WT_implies_WTrt)
moreover from sees have "P ⊢ C' ≼⇧* D" by(rule sees_method_decl_above)
with h'a' have "P,h' ⊢ [this ↦ Addr a'] (:≤) [this ↦ Class D]" by(auto simp add: lconf_def conf_def)
ultimately show ?case using h'a' sees ‹s' = (h', lcl s)›
‹extNTA2J P (C', M', a') = (e'', x'')› by(fastforce intro: sees_method_decl_above)
qed(fastforce simp add: ta_upd_simps)+
end
context J_heap_conf_base begin
definition sconf_type_ok :: "(env × ty) ⇒ 'thread_id ⇒ 'addr expr × 'addr locals ⇒ 'heap ⇒ bool"
where
"sconf_type_ok ET t ex h ≡ fst ET ⊢ (h, snd ex) √ ∧ type_ok P ET (fst ex) h ∧ P,h ⊢ t √t"
abbreviation sconf_type_ts_ok ::
"('thread_id ⇀ (env × ty)) ⇒ ('addr,'thread_id,'addr expr × 'addr locals) thread_info ⇒ 'heap ⇒ bool"
where
"sconf_type_ts_ok ≡ ts_inv sconf_type_ok"
lemma ts_inv_ok_J_sconf_type_ET_start:
"ts_inv_ok (thr (J_start_state P C M vs)) (J_sconf_type_ET_start P C M)"
by(rule ts_inv_okI)(simp add: start_state_def J_sconf_type_ET_start_def split_beta)
end
lemma (in J_heap) red_preserve_welltype:
"⟦ extTA,P,t ⊢ ⟨e, (h, x)⟩ -ta→ ⟨e', (h', x')⟩; P,E,h ⊢ e'' : T ⟧ ⟹ P,E,h' ⊢ e'' : T"
by(auto elim: WTrt_hext_mono dest!: red_hext_incr)
context J_heap_conf begin
lemma sconf_type_ts_ok_J_start_state:
"⟦ wf_J_prog P; wf_start_state P C M vs ⟧
⟹ sconf_type_ts_ok (J_sconf_type_ET_start P C M) (thr (J_start_state P C M vs)) (shr (J_start_state P C M vs))"
apply(erule wf_start_state.cases)
apply(rule ts_invI)
apply(simp add: start_state_def split: if_split_asm)
apply(frule (1) sees_wf_mdecl)
apply(auto simp add: wf_mdecl_def J_sconf_type_ET_start_def sconf_type_ok_def sconf_def type_ok_def)
apply(erule hconf_start_heap)
apply(erule preallocated_start_heap)
apply(erule wf_prog_wf_syscls)
apply(frule list_all2_lengthD)
apply(auto simp add: wt_blocks confs_conv_map intro: WT_implies_WTrt)[1]
apply(erule tconf_start_heap_start_tid)
apply(erule wf_prog_wf_syscls)
done
lemma J_start_state_sconf_type_ok:
assumes wf: "wf_J_prog P"
and ok: "wf_start_state P C M vs"
shows "ts_ok (λt x h. ∃ET. sconf_type_ok ET t x h) (thr (J_start_state P C M vs)) start_heap"
using sconf_type_ts_ok_J_start_state[OF assms]
unfolding shr_start_state by(rule ts_inv_into_ts_ok_Ex)
end
context J_conf_read begin
lemma red_preserves_type_ok:
"⟦ extTA,P,t ⊢ ⟨e,s⟩ -ta→ ⟨e',s'⟩; wf_J_prog P; E ⊢ s √; type_ok P (E, T) e (hp s); P,hp s ⊢ t √t ⟧ ⟹ type_ok P (E, T) e' (hp s')"
apply(clarsimp simp add: type_ok_def)
apply(subgoal_tac "∃T''. P,E,hp s' ⊢ e' : T'' ∧ P ⊢ T'' ≤ T'")
apply(fast elim: widen_trans)
by(rule subject_reduction)
lemma lifting_inv_sconf_subject_ok:
assumes wf: "wf_J_prog P"
shows "lifting_inv final_expr (mred P) sconf_type_ok"
proof(unfold_locales)
fix t x m ta x' m' i
assume mred: "mred P t (x, m) ta (x', m')"
and "sconf_type_ok i t x m"
moreover obtain e l where x [simp]: "x = (e, l)" by(cases x, auto)
moreover obtain e' l' where x' [simp]: "x' = (e', l')" by(cases x', auto)
moreover obtain E T where i [simp]: "i = (E, T)" by(cases i, auto)
ultimately have sconf_type: "sconf_type_ok (E, T) t (e, l) m"
and red: "P,t ⊢ ⟨e, (m, l)⟩ -ta→ ⟨e', (m', l')⟩" by auto
from sconf_type have sconf: "E ⊢ (m, l) √" and "type_ok P (E, T) e m" and tconf: "P,m ⊢ t √t"
by(auto simp add: sconf_type_ok_def)
then obtain T' where "P,E,m ⊢ e : T'" "P ⊢ T' ≤ T" by(auto simp add: type_ok_def)
from ‹E ⊢ (m, l) √› ‹P,E,m ⊢ e : T'› red tconf
have "E ⊢ (m', l') √" by(auto elim: red_preserves_sconf)
moreover
from red ‹P,E,m ⊢ e : T'› wf ‹E ⊢ (m, l) √› tconf
obtain T'' where "P,E,m' ⊢ e' : T''" "P ⊢ T'' ≤ T'"
by(auto dest: subject_reduction)
note ‹P,E,m' ⊢ e' : T''›
moreover
from ‹P ⊢ T'' ≤ T'› ‹P ⊢ T' ≤ T›
have "P ⊢ T'' ≤ T" by(rule widen_trans)
moreover from mred tconf have "P,m' ⊢ t √t" by(rule red_tconf.preserves_red)
ultimately have "sconf_type_ok (E, T) t (e', l') m'"
by(auto simp add: sconf_type_ok_def type_ok_def)
thus "sconf_type_ok i t x' m'" by simp
next
fix t x m ta x' m' i t'' x''
assume mred: "mred P t (x, m) ta (x', m')"
and "sconf_type_ok i t x m"
and "NewThread t'' x'' m' ∈ set ⦃ta⦄⇘t⇙"
moreover obtain e l where x [simp]: "x = (e, l)" by(cases x, auto)
moreover obtain e' l' where x' [simp]: "x' = (e', l')" by(cases x', auto)
moreover obtain E T where i [simp]: "i = (E, T)" by(cases i, auto)
moreover obtain e'' l'' where x'' [simp]: "x'' = (e'', l'')" by(cases x'', auto)
ultimately have sconf_type: "sconf_type_ok (E, T) t (e, l) m"
and red: "P,t ⊢ ⟨e, (m, l)⟩ -ta→ ⟨e', (m', l')⟩"
and nt: "NewThread t'' (e'', l'') m' ∈ set ⦃ta⦄⇘t⇙" by auto
from sconf_type have sconf: "E ⊢ (m, l) √" and "type_ok P (E, T) e m" and tconf: "P,m ⊢ t √t"
by(auto simp add: sconf_type_ok_def)
then obtain T' where "P,E,m ⊢ e : T'" "P ⊢ T' ≤ T" by(auto simp add: type_ok_def)
from nt ‹P,E,m ⊢ e : T'› red have "∃E T. P,E,m' ⊢ e'' : T ∧ P,m' ⊢ l'' (:≤) E"
by(fastforce dest: red_type_newthread[OF wf])
then obtain E'' T'' where "P,E'',m' ⊢ e'' : T''" "P,m' ⊢ l'' (:≤) E''" by blast
moreover
from sconf red ‹P,E,m ⊢ e : T'› tconf have "E ⊢ (m', l') √"
by(auto intro: red_preserves_sconf)
moreover from mred tconf ‹NewThread t'' x'' m' ∈ set ⦃ta⦄⇘t⇙› have "P,m' ⊢ t'' √t"
by(rule red_tconf.preserves_NewThread)
ultimately show "∃i''. sconf_type_ok i'' t'' x'' m'"
by(auto simp add: sconf_type_ok_def type_ok_def sconf_def)
next
fix t x m ta x' m' i i'' t'' x''
assume mred: "mred P t (x, m) ta (x', m')"
and "sconf_type_ok i t x m"
and "sconf_type_ok i'' t'' x'' m"
moreover obtain e l where x [simp]: "x = (e, l)" by(cases x, auto)
moreover obtain e' l' where x' [simp]: "x' = (e', l')" by(cases x', auto)
moreover obtain E T where i [simp]: "i = (E, T)" by(cases i, auto)
moreover obtain e'' l'' where x'' [simp]: "x'' = (e'', l'')" by(cases x'', auto)
moreover obtain E'' T'' where i'' [simp]: "i'' = (E'', T'')" by(cases i'', auto)
ultimately have sconf_type: "sconf_type_ok (E, T) t (e, l) m"
and red: "P,t ⊢ ⟨e, (m, l)⟩ -ta→ ⟨e', (m', l')⟩"
and sc: "sconf_type_ok (E'', T'') t'' (e'', l'') m" by auto
from sconf_type obtain T' where "P,E,m ⊢ e : T'" and "P,m ⊢ t √t"
by(auto simp add: sconf_type_ok_def type_ok_def)
from sc have sconf: "E'' ⊢ (m, l'') √" and "type_ok P (E'', T'') e'' m" and "P,m ⊢ t'' √t"
by(auto simp add: sconf_type_ok_def)
then obtain T''' where "P,E'',m ⊢ e'' : T'''" "P ⊢ T''' ≤ T''" by(auto simp add: type_ok_def)
moreover from red ‹P,E'',m ⊢ e'' : T'''› have "P,E'',m' ⊢ e'' : T'''"
by(rule red_preserve_welltype)
moreover from sconf red ‹P,E,m ⊢ e : T'› have "hconf m'"
unfolding sconf_def by(auto dest: red_preserves_hconf)
moreover {
from red have "hext m m'" by(auto dest: red_hext_incr)
moreover from sconf have "P,m ⊢ l'' (:≤) E''" "preallocated m"
by(simp_all add: sconf_def)
ultimately have "P,m' ⊢ l'' (:≤) E''" "preallocated m'"
by(blast intro: lconf_hext preallocated_hext)+ }
moreover from mred ‹P,m ⊢ t √t› ‹P,m ⊢ t'' √t›
have "P,m' ⊢ t'' √t" by(rule red_tconf.preserves_other)
ultimately have "sconf_type_ok (E'', T'') t'' (e'', l'') m'"
by(auto simp add: sconf_type_ok_def sconf_def type_ok_def)
thus "sconf_type_ok i'' t'' x'' m'" by simp
qed
end
subsection ‹@{term "wf_red"}›
context J_progress begin
context begin
declare red_mthr.actions_ok_iff [simp del]
declare red_mthr.actions_ok.cases [rule del]
declare red_mthr.actions_ok.intros [rule del]
lemma assumes wf: "wf_prog wf_md P"
shows red_wf_red_aux:
"⟦ P,t ⊢ ⟨e, s⟩ -ta→ ⟨e',s'⟩; ¬ red_mthr.actions_ok' (ls, (ts, m), ws, is) t ta;
sync_ok e; hconf (hp s); P,hp s ⊢ t √t;
∀l. has_locks (ls $ l) t ≥ expr_locks e l;
ws t = None ∨
(∃a vs w T Ts Tr D. call e = ⌊(a, wait, vs)⌋ ∧ typeof_addr (hp s) a = ⌊T⌋ ∧ P ⊢ class_type_of T sees wait: Ts→Tr = Native in D ∧ ws t = ⌊PostWS w⌋) ⟧
⟹ ∃e'' s'' ta'. P,t ⊢ ⟨e, s⟩ -ta'→ ⟨e'',s''⟩ ∧
(red_mthr.actions_ok (ls, (ts, m), ws, is) t ta' ∨
red_mthr.actions_ok' (ls, (ts, m), ws, is) t ta' ∧ red_mthr.actions_subset ta' ta)"
(is "⟦ _; _; _; _; _; _; ?wakeup e s ⟧ ⟹ ?concl e s ta")
and reds_wf_red_aux:
"⟦ P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es',s'⟩; ¬ red_mthr.actions_ok' (ls, (ts, m), ws, is) t ta;
sync_oks es; hconf (hp s); P,hp s ⊢ t √t;
∀l. has_locks (ls $ l) t ≥ expr_lockss es l;
ws t = None ∨
(∃a vs w T Ts T Tr D. calls es = ⌊(a, wait, vs)⌋ ∧ typeof_addr (hp s) a = ⌊T⌋ ∧ P ⊢ class_type_of T sees wait: Ts→Tr = Native in D ∧ ws t = ⌊PostWS w⌋) ⟧
⟹ ∃es'' s'' ta'. P,t ⊢ ⟨es, s⟩ [-ta'→] ⟨es'',s''⟩ ∧
(red_mthr.actions_ok (ls, (ts, m), ws, is) t ta' ∨
red_mthr.actions_ok' (ls, (ts, m), ws, is) t ta' ∧ red_mthr.actions_subset ta' ta)"
proof(induct rule: red_reds.inducts)
case (SynchronizedRed2 e s ta e' s' a)
note IH = ‹⟦¬ red_mthr.actions_ok' (ls, (ts, m), ws, is) t ta; sync_ok e; hconf (hp s); P,hp s ⊢ t √t;
∀l. expr_locks e l ≤ has_locks (ls $ l) t; ?wakeup e s⟧
⟹ ?concl e s ta›
note ‹¬ red_mthr.actions_ok' (ls, (ts, m), ws, is) t ta›
moreover from ‹sync_ok (insync(a) e)› have "sync_ok e" by simp
moreover note ‹hconf (hp s)› ‹P,hp s ⊢ t √t›
moreover from ‹∀l. expr_locks (insync(a) e) l ≤ has_locks (ls $ l) t›
have "∀l. expr_locks e l ≤ has_locks (ls $ l) t" by(force split: if_split_asm)
moreover from ‹?wakeup (insync(a) e) s› have "?wakeup e s" by auto
ultimately have "?concl e s ta" by(rule IH)
thus ?case by(fastforce intro: red_reds.SynchronizedRed2)
next
case RedCall thus ?case
by(auto simp add: is_val_iff contains_insync_conv contains_insyncs_conv red_mthr.actions_ok'_empty red_mthr.actions_ok'_ta_upd_obs dest: sees_method_fun)
next
case (RedCallExternal s a U M Ts T D vs ta va h' ta' e' s')
from ‹?wakeup (addr a∙M(map Val vs)) s›
have "wset (ls, (ts, m), ws, is) t = None ∨ (M = wait ∧ (∃w. wset (ls, (ts, m), ws, is) t = ⌊PostWS w⌋))" by auto
with wf ‹P,t ⊢ ⟨a∙M(vs),hp s⟩ -ta→ext ⟨va, h'⟩› ‹P,hp s ⊢ t √t› ‹hconf (hp s)›
obtain ta'' va' h'' where red': "P,t ⊢ ⟨a∙M(vs),hp s⟩ -ta''→ext ⟨va',h''⟩"
and aok: "red_mthr.actions_ok (ls, (ts, m), ws, is) t ta'' ∨
red_mthr.actions_ok' (ls, (ts, m), ws, is) t ta'' ∧ final_thread.actions_subset ta'' ta"
by(rule red_external_wf_red)
from aok ‹ta' = extTA2J P ta›
have "red_mthr.actions_ok (ls, (ts, m), ws, is) t (extTA2J P ta'') ∨
red_mthr.actions_ok' (ls, (ts, m), ws, is) t (extTA2J P ta'') ∧ red_mthr.actions_subset (extTA2J P ta'') ta'"
by(auto simp add: red_mthr.actions_ok'_convert_extTA red_mthr.actions_ok_iff elim: final_thread.actions_subset.cases del: subsetI)
moreover from red' ‹typeof_addr (hp s) a = ⌊U⌋› ‹P ⊢ class_type_of U sees M: Ts→T = Native in D›
obtain s'' e'' where "P,t ⊢ ⟨addr a∙M(map Val vs),s⟩ -extTA2J P ta''→ ⟨e'',s''⟩"
by(fastforce intro: red_reds.RedCallExternal)
ultimately show ?case by blast
next
case LockSynchronized
hence False by(auto simp add: lock_ok_las'_def finfun_upd_apply ta_upd_simps)
thus ?case ..
next
case (UnlockSynchronized a v s)
from ‹∀l. expr_locks (insync(a) Val v) l ≤ has_locks (ls $ l) t›
have "has_lock (ls $ a) t" by(force split: if_split_asm)
with UnlockSynchronized have False by(auto simp add: lock_ok_las'_def finfun_upd_apply ta_upd_simps)
thus ?case ..
next
case (SynchronizedThrow2 a ad s)
from ‹∀l. expr_locks (insync(a) Throw ad) l ≤ has_locks (ls $ l) t›
have "has_lock (ls $ a) t" by(force split: if_split_asm)
with SynchronizedThrow2 have False
by(auto simp add: lock_ok_las'_def finfun_upd_apply ta_upd_simps)
thus ?case ..
next
case BlockRed thus ?case by(simp)(blast intro: red_reds.intros)
qed
(simp_all add: is_val_iff contains_insync_conv contains_insyncs_conv red_mthr.actions_ok'_empty
red_mthr.actions_ok'_ta_upd_obs thread_action'_to_thread_action.simps red_mthr.actions_ok_iff
split: if_split_asm del: split_paired_Ex,
(blast intro: red_reds.intros elim: add_leE)+)
end
end
context J_heap_base begin
lemma shows red_ta_satisfiable:
"P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩ ⟹ ∃s. red_mthr.actions_ok s t ta"
and reds_ta_satisfiable:
"P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩ ⟹ ∃s. red_mthr.actions_ok s t ta"
apply(induct rule: red_reds.inducts)
apply(fastforce simp add: lock_ok_las_def finfun_upd_apply intro: exI[where x="K$ None"] exI[where x="K$ ⌊(t, 0)⌋"] may_lock.intros dest: red_external_ta_satisfiable[where final="final_expr :: ('addr expr × 'addr locals) ⇒ bool"])+
done
end
context J_typesafe begin
lemma wf_progress:
assumes wf: "wf_J_prog P"
shows "progress final_expr (mred P)
(red_mthr.wset_Suspend_ok P ({s. sync_es_ok (thr s) (shr s) ∧ lock_ok (locks s) (thr s)} ∩ {s. ∃Es. sconf_type_ts_ok Es (thr s) (shr s)} ∩ {s. def_ass_ts_ok (thr s) (shr s)}))"
(is "progress _ _ ?wf_state")
proof
{
fix s t x ta x' m' w
assume "mred P t (x, shr s) ta (x', m')"
and Suspend: "Suspend w ∈ set ⦃ta⦄⇘w⇙"
moreover obtain e xs where x: "x = (e, xs)" by(cases x)
moreover obtain e' xs' where x': "x' = (e', xs')" by(cases x')
ultimately have red: "P,t ⊢ ⟨e, (shr s, xs)⟩ -ta→ ⟨e', (m', xs')⟩" by simp
from red_Suspend_is_call[OF red Suspend]
show "¬ final_expr x'" by(auto simp add: x')
}
note Suspend_final = this
{
fix s
assume s: "s ∈ ?wf_state"
hence "lock_thread_ok (locks s) (thr s)"
by(auto dest: red_mthr.wset_Suspend_okD1 intro: lock_ok_lock_thread_ok)
moreover
have "red_mthr.wset_final_ok (wset s) (thr s)"
proof(rule red_mthr.wset_final_okI)
fix t w
assume "wset s t = ⌊w⌋"
from red_mthr.wset_Suspend_okD2[OF s this]
obtain x0 ta x m1 w' ln'' and s0 :: "('addr, 'thread_id, 'heap) J_state"
where mred: "mred P t (x0, shr s0) ta (x, m1)"
and Suspend: "Suspend w' ∈ set ⦃ta⦄⇘w⇙"
and tst: "thr s t = ⌊(x, ln'')⌋" by blast
from Suspend_final[OF mred Suspend] tst
show " ∃x ln. thr s t = ⌊(x, ln)⌋ ∧ ¬ final_expr x" by blast
qed
ultimately show "lock_thread_ok (locks s) (thr s) ∧ red_mthr.wset_final_ok (wset s) (thr s)" ..
}
next
fix s t ex ta e'x' m'
assume wfs: "s ∈ ?wf_state"
and "thr s t = ⌊(ex, no_wait_locks)⌋"
and "mred P t (ex, shr s) ta (e'x', m')"
and wait: "¬ waiting (wset s t)"
moreover obtain ls ts m ws "is" where s: "s = (ls, (ts, m), ws, is)" by(cases s) fastforce
moreover obtain e x where ex: "ex = (e, x)" by(cases ex)
moreover obtain e' x' where e'x': "e'x' = (e', x')" by(cases e'x')
ultimately have tst: "ts t = ⌊(ex, no_wait_locks)⌋"
and red: "P,t ⊢ ⟨e, (m, x)⟩ -ta→ ⟨e', (m', x')⟩" by auto
from wf have wwf: "wwf_J_prog P" by(rule wf_prog_wwf_prog)
from wfs s obtain Es where aeos: "sync_es_ok ts m"
and lockok: "lock_ok ls ts"
and "sconf_type_ts_ok Es ts m"
by(auto dest: red_mthr.wset_Suspend_okD1)
with tst ex obtain E T where sconf: "sconf_type_ok (E, T) t (e, x) m"
and aoe: "sync_ok e" by(fastforce dest: ts_okD ts_invD)
then obtain T' where "hconf m" "P,E,m ⊢ e : T'" "preallocated m"
by(auto simp add: sconf_type_ok_def sconf_def type_ok_def)
from ‹sconf_type_ts_ok Es ts m› s have "thread_conf P (thr s) (shr s)"
by(auto dest: ts_invD intro!: ts_okI simp add: sconf_type_ok_def)
with ‹thr s t = ⌊(ex, no_wait_locks)⌋› have "P,shr s ⊢ t √t" by(auto dest: ts_okD)
show "∃ta' x' m'. mred P t (ex, shr s) ta' (x', m') ∧
(red_mthr.actions_ok s t ta' ∨ red_mthr.actions_ok' s t ta' ∧ red_mthr.actions_subset ta' ta)"
proof(cases "red_mthr.actions_ok' s t ta")
case True
have "red_mthr.actions_subset ta ta" ..
with True ‹mred P t (ex, shr s) ta (e'x', m')› show ?thesis by blast
next
case False
from lock_okD2[OF lockok, OF tst[unfolded ex]]
have locks: "∀l. has_locks (ls $ l) t ≥ expr_locks e l" by simp
have "ws t = None ∨ (∃a vs w T Ts Tr D. call e = ⌊(a, wait, vs)⌋ ∧ typeof_addr (hp (m, x)) a = ⌊T⌋ ∧ P ⊢ class_type_of T sees wait: Ts→Tr = Native in D ∧ ws t = ⌊PostWS w⌋)"
proof(cases "ws t")
case None thus ?thesis ..
next
case (Some w)
with red_mthr.wset_Suspend_okD2[OF wfs, of t w] tst ex s
obtain e0 x0 m0 ta0 w' s1 tta1
where red0: "P,t ⊢ ⟨e0, (m0, x0)⟩ -ta0→ ⟨e, (shr s1, x)⟩"
and Suspend: "Suspend w' ∈ set ⦃ta0⦄⇘w⇙"
and s1: "P ⊢ s1 -▹tta1→* s" by auto
from red_Suspend_is_call[OF red0 Suspend] obtain a vs T Ts Tr D
where call: "call e = ⌊(a, wait, vs)⌋"
and type: "typeof_addr m0 a = ⌊T⌋"
and iec: "P ⊢ class_type_of T sees wait: Ts→Tr = Native in D" by fastforce
from red0 have "m0 ⊴ shr s1" by(auto dest: red_hext_incr)
also from s1 have "shr s1 ⊴ shr s" by(rule RedT_hext_incr)
finally have "typeof_addr (shr s) a = ⌊T⌋" using type
by(rule typeof_addr_hext_mono)
moreover from Some wait s obtain w' where "ws t = ⌊PostWS w'⌋"
by(auto simp add: not_waiting_iff)
ultimately show ?thesis using call iec s by auto
qed
from red_wf_red_aux[OF wf red False[unfolded s] aoe _ _ locks, OF _ _ this] ‹hconf m› ‹P,shr s ⊢ t √t› ex s
show ?thesis by fastforce
qed
next
fix s t x
assume wfs: "s ∈ ?wf_state"
and tst: "thr s t = ⌊(x, no_wait_locks)⌋"
and nfin: "¬ final_expr x"
obtain e xs where x: "x = (e, xs)" by(cases x)
from wfs have "def_ass_ts_ok (thr s) (shr s)" by(auto dest: red_mthr.wset_Suspend_okD1)
with tst x have DA: "𝒟 e ⌊dom xs⌋" by(auto dest: ts_okD)
from wfs obtain Es where "sconf_type_ts_ok Es (thr s) (shr s)"
by(auto dest: red_mthr.wset_Suspend_okD1)
with tst x obtain E T where "sconf_type_ok (E, T) t (e, xs) (shr s)" by(auto dest: ts_invD)
then obtain T' where "hconf (shr s)" "P,E,shr s ⊢ e : T'"
by(auto simp add: sconf_type_ok_def sconf_def type_ok_def)
from red_progress(1)[OF wf_prog_wwf_prog[OF wf] this DA, where extTA="extTA2J P" and t=t] nfin x
show "∃ta x' m'. mred P t (x, shr s) ta (x', m')" by fastforce
next
fix s t x xm ta xm'
assume "s ∈ ?wf_state"
and "thr s t = ⌊(x, no_wait_locks)⌋"
and "mred P t xm ta xm'"
and "Notified ∈ set ⦃ta⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta⦄⇘w⇙"
thus "collect_waits ta = {}"
by(auto dest: red_ta_Wakeup_no_Join_no_Lock_no_Interrupt simp: split_beta)
next
fix s t x ta x' m'
assume "s ∈ ?wf_state"
and "thr s t = ⌊(x, no_wait_locks)⌋"
and "mred P t (x, shr s) ta (x', m')"
thus "∃s'. red_mthr.actions_ok s' t ta"
by(fastforce simp add: split_beta dest!: red_ta_satisfiable)
qed
lemma redT_progress_deadlock:
assumes wf: "wf_J_prog P"
and wf_start: "wf_start_state P C M vs"
and Red: "P ⊢ J_start_state P C M vs -▹ttas→* s"
and ndead: "¬ red_mthr.deadlock P s"
shows "∃t' ta' s'. P ⊢ s -t'▹ta'→ s'"
proof -
let ?wf_state = "red_mthr.wset_Suspend_ok P ({s. sync_es_ok (thr s) (shr s) ∧ lock_ok (locks s) (thr s)} ∩ {s. ∃Es. sconf_type_ts_ok Es (thr s) (shr s)} ∩ {s. def_ass_ts_ok (thr s) (shr s)})"
interpret red_mthr: progress
final_expr "mred P" convert_RA ?wf_state
using wf by(rule wf_progress)
from wf_start obtain Ts T pns body D
where start: "start_heap_ok" "P ⊢ C sees M:Ts→T = ⌊(pns, body)⌋ in D" "P,start_heap ⊢ vs [:≤] Ts"
by(cases) auto
from start have len: "length Ts = length vs" by(auto dest: list_all2_lengthD)
have "invariant3p (mredT P) ?wf_state"
by(rule red_mthr.invariant3p_wset_Suspend_ok) (intro invariant3p_IntI invariant3p_sync_es_ok_lock_ok[OF wf] lifting_inv.invariant3p_ts_inv[OF lifting_inv_sconf_subject_ok[OF wf]] lifting_wf.invariant3p_ts_ok[OF lifting_wf_def_ass[OF wf]])
moreover note Red moreover
have start': "J_start_state P C M vs ∈ ?wf_state"
apply(rule red_mthr.wset_Suspend_okI)
apply(blast intro: sconf_type_ts_ok_J_start_state sync_es_ok_J_start_state lock_ok_J_start_state def_ass_ts_ok_J_start_state start wf len len[symmetric] wf_start)
apply(simp add: start_state_def split_beta)
done
ultimately have "s ∈ ?wf_state" unfolding red_mthr.RedT_def
by(rule invariant3p_rtrancl3p)
thus ?thesis using ndead by(rule red_mthr.redT_progress)
qed
lemma redT_progress_deadlocked:
assumes wf: "wf_J_prog P"
and wf_start: "wf_start_state P C M vs"
and Red: "P ⊢ J_start_state P C M vs -▹ttas→* s"
and ndead: "red_mthr.not_final_thread s t" "¬ t ∈ red_mthr.deadlocked P s"
shows "∃t' ta' s'. P ⊢ s -t'▹ta'→ s'"
using wf wf_start Red
proof(rule redT_progress_deadlock)
from ndead show "¬ red_mthr.deadlock P s"
unfolding red_mthr.deadlock_eq_deadlocked'
by(auto simp add: red_mthr.deadlocked'_def)
qed
subsection ‹Type safety proof›
theorem TypeSafetyT:
fixes C and M and ttas and Es
defines "Es == J_sconf_type_ET_start P C M"
and "Es' == upd_invs Es sconf_type_ok (concat (map (thr_a ∘ snd) ttas))"
assumes wf: "wf_J_prog P"
and start_wf: "wf_start_state P C M vs"
and RedT: "P ⊢ J_start_state P C M vs -▹ttas→* s'"
and nored: "¬ (∃t ta s''. P ⊢ s' -t▹ta→ s'')"
shows "thread_conf P (thr s') (shr s')"
and "thr s' t = ⌊((e', x'), ln')⌋ ⟹
(∃v. e' = Val v ∧ (∃E T. Es' t = ⌊(E, T)⌋ ∧ P,shr s' ⊢ v :≤ T) ∧ ln' = no_wait_locks)
∨ (∃a C. e' = Throw a ∧ typeof_addr (shr s') a = ⌊Class_type C⌋ ∧ P ⊢ C ≼⇧* Throwable ∧ ln' = no_wait_locks)
∨ (t ∈ red_mthr.deadlocked P s' ∧ (∃E T. Es' t = ⌊(E, T)⌋ ∧ (∃T'. P,E,shr s' ⊢ e' : T' ∧ P ⊢ T' ≤ T)))"
(is "_ ⟹ ?thesis2")
and "Es ⊆⇩m Es'"
proof -
from start_wf obtain Ts T pns body D
where start_heap: "start_heap_ok"
and sees: "P ⊢ C sees M:Ts→T = ⌊(pns, body)⌋ in D"
and conf: "P,start_heap ⊢ vs [:≤] Ts"
by cases auto
from RedT show "thread_conf P (thr s') (shr s')"
by(rule red_tconf.RedT_preserves)(rule thread_conf_start_state[OF start_heap wf_prog_wf_syscls[OF wf]])
show "Es ⊆⇩m Es'" using RedT ts_inv_ok_J_sconf_type_ET_start
unfolding Es'_def Es_def by(rule red_mthr.RedT_upd_inv_ext)
assume "thr s' t = ⌊((e', x'), ln')⌋"
moreover obtain ls' ts' m' ws' is' where s' [simp]: "s' = (ls', (ts', m'), ws', is')" by(cases s') fastforce
ultimately have es't: "ts' t = ⌊((e', x'), ln')⌋" by simp
from wf have wwf: "wwf_J_prog P" by(rule wf_prog_wwf_prog)
from conf have len: "length vs = length Ts" by(rule list_all2_lengthD)
from RedT def_ass_ts_ok_J_start_state[OF wf sees len] have defass': "def_ass_ts_ok ts' m'"
by(fastforce dest: lifting_wf.RedT_preserves[OF lifting_wf_def_ass, OF wf])
from RedT sync_es_ok_J_start_state[OF wf sees len[symmetric]] lock_ok_J_start_state[OF wf sees len[symmetric]]
have lock': "lock_ok ls' ts'" by (fastforce dest: RedT_preserves_lock_ok[OF wf])
from RedT sync_es_ok_J_start_state[OF wf sees len[symmetric]] have addr': "sync_es_ok ts' m'"
by(fastforce dest: RedT_preserves_sync_ok[OF wf])
from RedT sconf_type_ts_ok_J_start_state[OF wf start_wf]
have sconf_subject': "sconf_type_ts_ok Es' ts' m'" unfolding Es'_def Es_def
by(fastforce dest: lifting_inv.RedT_invariant[OF lifting_inv_sconf_subject_ok, OF wf] intro: thread_conf_start_state[OF _ wf_prog_wf_syscls[OF wf]])
with es't obtain E T where ET: "Es' t = ⌊(E, T)⌋"
and "sconf_type_ok (E, T) t (e', x') m'" by(auto dest!: ts_invD)
{ assume "final e'"
have "ln' = no_wait_locks"
proof(rule ccontr)
assume "ln' ≠ no_wait_locks"
then obtain l where "ln' $ l > 0"
by(auto simp add: neq_no_wait_locks_conv)
from lock' es't have "has_locks (ls' $ l) t + ln' $ l = expr_locks e' l"
by(auto dest: lock_okD2)
with ‹ln' $ l > 0› have "expr_locks e' l > 0" by simp
moreover from ‹final e'› have "expr_locks e' l = 0" by(rule final_locks)
ultimately show False by simp
qed }
note ln' = this
{ assume "∃v. e' = Val v"
then obtain v where v: "e' = Val v" by blast
with sconf_subject' ET es't have "P,m' ⊢ v :≤ T"
by(auto dest: ts_invD simp add: type_ok_def sconf_type_ok_def conf_def)
moreover from v ln' have "ln' = no_wait_locks" by(auto)
ultimately have "∃v. e' = Val v ∧ (∃E T. Es' t = ⌊(E, T)⌋ ∧ P,m' ⊢ v :≤ T ∧ ln' = no_wait_locks)"
using ET v by blast }
moreover
{ assume "∃a. e' = Throw a"
then obtain a where a: "e' = Throw a" by blast
with sconf_subject' ET es't have "∃T'. P,E,m' ⊢ e' : T' ∧ P ⊢ T' ≤ T"
apply -
apply(drule ts_invD, assumption)
by(clarsimp simp add: type_ok_def sconf_type_ok_def)
then obtain T' where "P,E,m' ⊢ e' : T'" and "P ⊢ T' ≤ T" by blast
with a have "∃C. typeof_addr m' a = ⌊Class_type C⌋ ∧ P ⊢ C ≼⇧* Throwable"
by(auto simp add: widen_Class)
moreover from a ln' have "ln' = no_wait_locks" by(auto)
ultimately have "∃a C. e' = Throw a ∧ typeof_addr m' a = ⌊Class_type C⌋ ∧ P ⊢ C ≼⇧* Throwable ∧ ln' = no_wait_locks"
using a by blast }
moreover
{ assume nfine': "¬ final e'"
with es't have "red_mthr.not_final_thread s' t"
by(auto intro: red_mthr.not_final_thread.intros)
with nored have "t ∈ red_mthr.deadlocked P s'"
by -(erule contrapos_np, rule redT_progress_deadlocked[OF wf start_wf RedT])
moreover
from ‹sconf_type_ok (E, T) t (e', x') m'›
obtain T'' where "P,E,m' ⊢ e' : T''" "P ⊢ T'' ≤ T"
by(auto simp add: sconf_type_ok_def type_ok_def)
with ET have "∃E T. Es' t = ⌊(E, T)⌋ ∧ (∃T'. P,E,m' ⊢ e' : T' ∧ P ⊢ T' ≤ T)"
by blast
ultimately have "t ∈ red_mthr.deadlocked P s' ∧ (∃E T. Es' t = ⌊(E, T)⌋ ∧ (∃T'. P,E,m' ⊢ e' : T' ∧ P ⊢ T' ≤ T))" .. }
ultimately show ?thesis2 by simp(blast)
qed
end
end
Theory Deadlocked
section ‹Preservation of Deadlock›
theory Deadlocked
imports
ProgressThreaded
begin
context J_progress begin
lemma red_wt_hconf_hext:
assumes wf: "wf_J_prog P"
and hconf: "hconf H"
and tconf: "P,H ⊢ t √t"
shows "⟦ convert_extTA extNTA,P,t ⊢ ⟨e, s⟩ -ta→ ⟨e', s'⟩; P,E,H ⊢ e : T; hext H (hp s) ⟧
⟹ ∃ta' e' s'. convert_extTA extNTA,P,t ⊢ ⟨e, (H, lcl s)⟩ -ta'→ ⟨e', s'⟩ ∧
collect_locks ⦃ta⦄⇘l⇙ = collect_locks ⦃ta'⦄⇘l⇙ ∧ collect_cond_actions ⦃ta⦄⇘c⇙ = collect_cond_actions ⦃ta'⦄⇘c⇙ ∧
collect_interrupts ⦃ta⦄⇘i⇙ = collect_interrupts ⦃ta'⦄⇘i⇙"
and "⟦ convert_extTA extNTA,P,t ⊢ ⟨es, s⟩ [-ta→] ⟨es', s'⟩; P,E,H ⊢ es [:] Ts; hext H (hp s) ⟧
⟹ ∃ta' es' s'. convert_extTA extNTA,P,t ⊢ ⟨es, (H, lcl s)⟩ [-ta'→] ⟨es', s'⟩ ∧
collect_locks ⦃ta⦄⇘l⇙ = collect_locks ⦃ta'⦄⇘l⇙ ∧ collect_cond_actions ⦃ta⦄⇘c⇙ = collect_cond_actions ⦃ta'⦄⇘c⇙ ∧
collect_interrupts ⦃ta⦄⇘i⇙ = collect_interrupts ⦃ta'⦄⇘i⇙"
proof(induct arbitrary: E T and E Ts rule: red_reds.inducts)
case (RedNew h' a h C l)
thus ?case
by(cases "allocate H (Class_type C) = {}")(fastforce simp add: ta_upd_simps intro: RedNewFail red_reds.RedNew)+
next
case (RedNewFail h C l)
thus ?case
by(cases "allocate H (Class_type C) = {}")(fastforce simp add: ta_upd_simps intro: red_reds.RedNewFail RedNew)+
next
case NewArrayRed thus ?case by(fastforce intro: red_reds.intros)
next
case (RedNewArray i h' a h T l E T')
thus ?case
by(cases "allocate H (Array_type T (nat (sint i))) = {}")(fastforce simp add: ta_upd_simps intro: red_reds.RedNewArray RedNewArrayFail)+
next
case RedNewArrayNegative thus ?case by(fastforce intro: red_reds.intros)
next
case (RedNewArrayFail i h T l E T')
thus ?case
by(cases "allocate H (Array_type T (nat (sint i))) = {}")(fastforce simp add: ta_upd_simps intro: RedNewArray red_reds.RedNewArrayFail)+
next
case CastRed thus ?case by(fastforce intro: red_reds.intros)
next
case (RedCast s v U T E T')
from ‹P,E,H ⊢ Cast T (Val v) : T'› show ?case
proof(rule WTrt_elim_cases)
fix T''
assume wt: "P,E,H ⊢ Val v : T''" "T' = T"
thus ?thesis
by(cases "P ⊢ T'' ≤ T")(fastforce intro: red_reds.RedCast red_reds.RedCastFail)+
qed
next
case (RedCastFail s v U T E T')
from ‹P,E,H ⊢ Cast T (Val v) : T'›
obtain T'' where "P,E,H ⊢ Val v : T''" "T = T'" by auto
thus ?case
by(cases "P ⊢ T'' ≤ T")(fastforce intro: red_reds.RedCast red_reds.RedCastFail)+
next
case InstanceOfRed thus ?case by(fastforce intro: red_reds.intros)
next
case RedInstanceOf thus ?case
using [[hypsubst_thin = true]]
by auto((rule exI conjI red_reds.RedInstanceOf)+, auto)
next
case BinOpRed1 thus ?case by(fastforce intro: red_reds.intros)
next
case BinOpRed2 thus ?case by(fastforce intro: red_reds.intros)
next
case RedBinOp thus ?case by(fastforce intro: red_reds.intros)
next
case RedBinOpFail thus ?case by(fastforce intro: red_reds.intros)
next
case RedVar thus ?case by(fastforce intro: red_reds.intros)
next
case LAssRed thus ?case by(fastforce intro: red_reds.intros)
next
case RedLAss thus ?case by(fastforce intro: red_reds.intros)
next
case AAccRed1 thus ?case by(fastforce intro: red_reds.intros)
next
case AAccRed2 thus ?case by(fastforce intro: red_reds.intros)
next
case RedAAccNull thus ?case by(fastforce intro: red_reds.intros)
next
case RedAAccBounds thus ?case
by(fastforce intro: red_reds.RedAAccBounds dest: hext_arrD)
next
case (RedAAcc h a T n i v l E T')
from ‹P,E,H ⊢ addr a⌊Val (Intg i)⌉ : T'›
have wt: "P,E,H ⊢ addr a : T'⌊⌉" by(auto)
with ‹H ⊴ hp (h, l)› ‹typeof_addr h a = ⌊Array_type T n⌋›
have Ha: "typeof_addr H a = ⌊Array_type T n⌋" by(auto dest: hext_arrD)
with ‹0 <=s i› ‹sint i < int n›
have "nat (sint i) < n"
by (simp add: word_sle_eq nat_less_iff)
with Ha have "P,H ⊢ a@ACell (nat (sint i)) : T"
by(auto intro: addr_loc_type.intros)
from heap_read_total[OF hconf this]
obtain v where "heap_read H a (ACell (nat (sint i))) v" by blast
with Ha ‹0 <=s i› ‹sint i < int n› show ?case
by(fastforce intro: red_reds.RedAAcc simp add: ta_upd_simps)
next
case AAssRed1 thus ?case by(fastforce intro: red_reds.intros)
next
case AAssRed2 thus ?case by(fastforce intro: red_reds.intros)
next
case AAssRed3 thus ?case by(fastforce intro: red_reds.intros)
next
case RedAAssNull thus ?case by(fastforce intro: red_reds.intros)
next
case RedAAssBounds thus ?case by(fastforce intro: red_reds.RedAAssBounds dest: hext_arrD)
next
case (RedAAssStore s a T n i w U E T')
from ‹P,E,H ⊢ addr a⌊Val (Intg i)⌉ := Val w : T'›
obtain T'' T''' where wt: "P,E,H ⊢ addr a : T''⌊⌉"
and wtw: "P,E,H ⊢ Val w : T'''" by auto
with ‹H ⊴ hp s› ‹typeof_addr (hp s) a = ⌊Array_type T n⌋›
have Ha: "typeof_addr H a = ⌊Array_type T n⌋" by(auto dest: hext_arrD)
from ‹typeof⇘hp s⇙ w = ⌊U⌋› wtw ‹H ⊴ hp s› have "typeof⇘H⇙ w = ⌊U⌋"
by(auto dest: type_of_hext_type_of)
with Ha ‹0 <=s i› ‹sint i < int n› ‹¬ P ⊢ U ≤ T› show ?case
by(fastforce intro: red_reds.RedAAssStore)
next
case (RedAAss h a T n i w U h' l E T')
from ‹P,E,H ⊢ addr a⌊Val (Intg i)⌉ := Val w : T'›
obtain T'' T''' where wt: "P,E,H ⊢ addr a : T''⌊⌉"
and wtw: "P,E,H ⊢ Val w : T'''" by auto
with ‹H ⊴ hp (h, l)› ‹typeof_addr h a = ⌊Array_type T n⌋›
have Ha: "typeof_addr H a = ⌊Array_type T n⌋" by(auto dest: hext_arrD)
from ‹typeof⇘h⇙ w = ⌊U⌋› wtw ‹H ⊴ hp (h, l)› have "typeof⇘H⇙ w = ⌊U⌋"
by(auto dest: type_of_hext_type_of)
moreover
with ‹P ⊢ U ≤ T› have conf: "P,H ⊢ w :≤ T"
by(auto simp add: conf_def)
from ‹0 <=s i› ‹sint i < int n›
have "nat (sint i) < n"
by (simp add: word_sle_eq nat_less_iff)
with Ha have "P,H ⊢ a@ACell (nat (sint i)) : T"
by(auto intro: addr_loc_type.intros)
from heap_write_total[OF hconf this conf]
obtain H' where "heap_write H a (ACell (nat (sint i))) w H'" ..
ultimately show ?case using ‹0 <=s i› ‹sint i < int n› Ha ‹P ⊢ U ≤ T›
by(fastforce simp del: split_paired_Ex intro: red_reds.RedAAss)
next
case ALengthRed thus ?case by(fastforce intro: red_reds.intros)
next
case (RedALength h a T n l E T')
from ‹P,E,H ⊢ addr a∙length : T'›
obtain T'' where [simp]: "T' = Integer"
and wta: "P,E,H ⊢ addr a : T''⌊⌉" by(auto)
then obtain n'' where "typeof_addr H a = ⌊Array_type T'' n''⌋" by(auto)
thus ?case by(fastforce intro: red_reds.RedALength)
next
case RedALengthNull show ?case by(fastforce intro: red_reds.RedALengthNull)
next
case FAccRed thus ?case by(fastforce intro: red_reds.intros)
next
case (RedFAcc h a D F v l E T)
from ‹P,E,H ⊢ addr a∙F{D} : T› obtain U C' fm
where wt: "P,E,H ⊢ addr a : U"
and icto: "class_type_of' U = ⌊C'⌋"
and has: "P ⊢ C' has F:T (fm) in D"
by(auto)
then obtain hU where Ha: "typeof_addr H a = ⌊hU⌋" "U = ty_of_htype hU" by(auto)
with icto ‹P ⊢ C' has F:T (fm) in D› have "P,H ⊢ a@CField D F : T"
by(auto intro: addr_loc_type.intros)
from heap_read_total[OF hconf this]
obtain v where "heap_read H a (CField D F) v" by blast
thus ?case by(fastforce intro: red_reds.RedFAcc simp add: ta_upd_simps)
next
case RedFAccNull thus ?case by(fastforce intro: red_reds.intros)
next
case FAssRed1 thus ?case by(fastforce intro: red_reds.intros)
next
case FAssRed2 thus ?case by(fastforce intro: red_reds.intros)
next
case RedFAssNull thus ?case by(fastforce intro: red_reds.intros)
next
case (RedFAss h a D F v h' l E T)
from ‹P,E,H ⊢ addr a∙F{D} := Val v : T› obtain U C' T' T2 fm
where wt: "P,E,H ⊢ addr a : U"
and icto: "class_type_of' U = ⌊C'⌋"
and has: "P ⊢ C' has F:T' (fm) in D"
and wtv: "P,E,H ⊢ Val v : T2"
and T2T: "P ⊢ T2 ≤ T'" by(auto)
moreover from wt obtain hU where Ha: "typeof_addr H a = ⌊hU⌋" "U = ty_of_htype hU" by(auto)
with icto has have adal: "P,H ⊢ a@CField D F : T'" by(auto intro: addr_loc_type.intros)
from wtv T2T have "P,H ⊢ v :≤ T'" by(auto simp add: conf_def)
from heap_write_total[OF hconf adal this]
obtain h' where "heap_write H a (CField D F) v h'" ..
thus ?case by(fastforce intro: red_reds.RedFAss)
next
case CASRed1 thus ?case by(fastforce intro: red_reds.intros)
next
case CASRed2 thus ?case by(fastforce intro: red_reds.intros)
next
case CASRed3 thus ?case by(fastforce intro: red_reds.intros)
next
case CASNull thus ?case by(fastforce intro: red_reds.intros)
next
case (RedCASSucceed h a D F v v' h' l)
note split_paired_Ex[simp del]
from RedCASSucceed.prems(1) obtain T' fm T2 T3 U C where *:
"T = Boolean" "class_type_of' U = ⌊C⌋" "P ⊢ C has F:T' (fm) in D"
"volatile fm" "P ⊢ T2 ≤ T'" "P ⊢ T3 ≤ T'"
"P,E,H ⊢ Val v : T2" "P,E,H ⊢ Val v' : T3" "P,E,H ⊢ addr a : U" by auto
then have adal: "P,H ⊢ a@CField D F : T'" by(auto intro: addr_loc_type.intros)
from heap_read_total[OF hconf this] obtain v'' where v': "heap_read H a (CField D F) v''" by blast
show ?case
proof(cases "v'' = v")
case True
from * have "P,H ⊢ v' :≤ T'" by(auto simp add: conf_def)
from heap_write_total[OF hconf adal this] True * v'
show ?thesis by(fastforce intro: red_reds.RedCASSucceed)
next
case False
then show ?thesis using * v' by(fastforce intro: RedCASFail)
qed
next
case (RedCASFail h a D F v'' v v' l)
note split_paired_Ex[simp del]
from RedCASFail.prems(1) obtain T' fm T2 T3 U C where *:
"T = Boolean" "class_type_of' U = ⌊C⌋" "P ⊢ C has F:T' (fm) in D"
"volatile fm" "P ⊢ T2 ≤ T'" "P ⊢ T3 ≤ T'"
"P,E,H ⊢ Val v : T2" "P,E,H ⊢ Val v' : T3" "P,E,H ⊢ addr a : U" by auto
then have adal: "P,H ⊢ a@CField D F : T'" by(auto intro: addr_loc_type.intros)
from heap_read_total[OF hconf this] obtain v''' where v'': "heap_read H a (CField D F) v'''" by blast
show ?case
proof(cases "v''' = v")
case True
from * have "P,H ⊢ v' :≤ T'" by(auto simp add: conf_def)
from heap_write_total[OF hconf adal this] True * v''
show ?thesis by(fastforce intro: red_reds.RedCASSucceed)
next
case False
then show ?thesis using * v'' by(fastforce intro: red_reds.RedCASFail)
qed
next
case CallObj thus ?case by(fastforce intro: red_reds.intros)
next
case CallParams thus ?case by(fastforce intro: red_reds.intros)
next
case (RedCall s a U M Ts T pns body D vs E T')
from ‹P,E,H ⊢ addr a∙M(map Val vs) : T'›
obtain U' C' Ts' meth D' Ts''
where wta: "P,E,H ⊢ addr a : U'"
and icto: "class_type_of' U' = ⌊C'⌋"
and sees: "P ⊢ C' sees M: Ts'→T' = meth in D'"
and wtes: "P,E,H ⊢ map Val vs [:] Ts''"
and widens: "P ⊢ Ts'' [≤] Ts'" by auto
from wta obtain hU' where Ha: "typeof_addr H a = ⌊hU'⌋" "U' = ty_of_htype hU'" by(auto)
moreover from ‹typeof_addr (hp s) a = ⌊U⌋› ‹H ⊴ hp s› Ha
have [simp]: "U = hU'" by(auto dest: typeof_addr_hext_mono)
from wtes have "length vs = length Ts''"
by(auto intro: map_eq_imp_length_eq)
moreover from widens have "length Ts'' = length Ts'"
by(auto dest: widens_lengthD)
moreover from sees icto sees ‹P ⊢ class_type_of U sees M: Ts→T = ⌊(pns, body)⌋ in D› Ha
have [simp]: "meth = ⌊(pns, body)⌋" by(auto dest: sees_method_fun)
with sees wf have "wf_mdecl wf_J_mdecl P D' (M, Ts', T', ⌊(pns, body)⌋)"
by(auto intro: sees_wf_mdecl)
hence "length pns = length Ts'" by(simp add: wf_mdecl_def)
ultimately show ?case using sees icto
by(fastforce intro: red_reds.RedCall)
next
case (RedCallExternal s a U M Ts T' D vs ta va h' ta' e' s')
from ‹P,E,H ⊢ addr a∙M(map Val vs) : T›
obtain U' C' Ts' meth D' Ts''
where wta: "P,E,H ⊢ addr a : U'" and icto: "class_type_of' U' = ⌊C'⌋"
and sees: "P ⊢ C' sees M: Ts'→T = meth in D'"
and wtvs: "P,E,H ⊢ map Val vs [:] Ts''"
and sub: "P ⊢ Ts'' [≤] Ts'" by auto
from wta ‹typeof_addr (hp s) a = ⌊U⌋› ‹hext H (hp s)› have [simp]: "U' = ty_of_htype U"
by(auto dest: typeof_addr_hext_mono)
with icto have [simp]: "C' = class_type_of U" by(auto)
from sees ‹P ⊢ class_type_of U sees M: Ts→T' = Native in D›
have [simp]: "meth = Native" by(auto dest: sees_method_fun)
with wta sees icto wtvs sub have "P,H ⊢ a∙M(vs) : T"
by(cases U)(auto 4 4 simp add: external_WT'_iff)
from red_external_wt_hconf_hext[OF wf ‹P,t ⊢ ⟨a∙M(vs),hp s⟩ -ta→ext ⟨va,h'⟩› ‹H ⊴ hp s› this tconf hconf]
wta icto sees ‹ta' = convert_extTA extNTA ta› ‹e' = extRet2J (addr a∙M(map Val vs)) va› ‹s' = (h', lcl s)›
show ?case by(cases U)(auto 4 5 intro: red_reds.RedCallExternal simp del: split_paired_Ex)
next
case RedCallNull thus ?case by(fastforce intro: red_reds.intros)
next
case (BlockRed e h l V vo ta e' h' l' T E T')
note IH = BlockRed.hyps(2)
from IH[of "E(V ↦ T)" T'] ‹P,E,H ⊢ {V:T=vo; e} : T'› ‹hext H (hp (h, l))›
show ?case by(fastforce dest: red_reds.BlockRed)
next
case RedBlock thus ?case by(fastforce intro: red_reds.intros)
next
case SynchronizedRed1 thus ?case by(fastforce intro: red_reds.intros)
next
case SynchronizedNull thus ?case by(fastforce intro: red_reds.intros)
next
case LockSynchronized thus ?case by(fastforce intro: red_reds.intros)
next
case SynchronizedRed2 thus ?case by(fastforce intro: red_reds.intros)
next
case UnlockSynchronized thus ?case by(fastforce intro: red_reds.intros)
next
case SeqRed thus ?case by(fastforce intro: red_reds.intros)
next
case RedSeq thus ?case by(fastforce intro: red_reds.intros)
next
case CondRed thus ?case by(fastforce intro: red_reds.intros)
next
case RedCondT thus ?case by(fastforce intro: red_reds.intros)
next
case RedCondF thus ?case by(fastforce intro: red_reds.intros)
next
case RedWhile thus ?case by(fastforce intro: red_reds.intros)
next
case ThrowRed thus ?case by(fastforce intro: red_reds.intros)
next
case RedThrowNull thus ?case by(fastforce intro: red_reds.intros)
next
case TryRed thus ?case by(fastforce intro: red_reds.intros)
next
case RedTry thus ?case by(fastforce intro: red_reds.intros)
next
case (RedTryCatch s a D C V e2 E T)
from ‹P,E,H ⊢ try Throw a catch(C V) e2 : T›
obtain T' where "P,E,H ⊢ addr a : T'" by auto
with ‹typeof_addr (hp s) a = ⌊Class_type D⌋› ‹hext H (hp s)›
have Ha: "typeof_addr H a = ⌊Class_type D⌋"
by(auto dest: typeof_addr_hext_mono)
with ‹P ⊢ D ≼⇧* C› show ?case
by(fastforce intro: red_reds.RedTryCatch)
next
case (RedTryFail s a D C V e2 E T)
from ‹P,E,H ⊢ try Throw a catch(C V) e2 : T›
obtain T' where "P,E,H ⊢ addr a : T'" by auto
with ‹typeof_addr (hp s) a = ⌊Class_type D⌋› ‹hext H (hp s)›
have Ha: "typeof_addr H a = ⌊Class_type D⌋"
by(auto dest: typeof_addr_hext_mono)
with ‹¬ P ⊢ D ≼⇧* C› show ?case
by(fastforce intro: red_reds.RedTryFail)
next
case ListRed1 thus ?case by(fastforce intro: red_reds.intros)
next
case ListRed2 thus ?case by(fastforce intro: red_reds.intros)
next
case NewArrayThrow thus ?case by(fastforce intro: red_reds.intros)
next
case CastThrow thus ?case by(fastforce intro: red_reds.intros)
next
case InstanceOfThrow thus ?case by(fastforce intro: red_reds.intros)
next
case BinOpThrow1 thus ?case by(fastforce intro: red_reds.intros)
next
case BinOpThrow2 thus ?case by(fastforce intro: red_reds.intros)
next
case LAssThrow thus ?case by(fastforce intro: red_reds.intros)
next
case AAccThrow1 thus ?case by(fastforce intro: red_reds.intros)
next
case AAccThrow2 thus ?case by(fastforce intro: red_reds.intros)
next
case AAssThrow1 thus ?case by(fastforce intro: red_reds.intros)
next
case AAssThrow2 thus ?case by(fastforce intro: red_reds.intros)
next
case AAssThrow3 thus ?case by(fastforce intro: red_reds.intros)
next
case ALengthThrow thus ?case by(fastforce intro: red_reds.intros)
next
case FAccThrow thus ?case by(fastforce intro: red_reds.intros)
next
case FAssThrow1 thus ?case by(fastforce intro: red_reds.intros)
next
case FAssThrow2 thus ?case by(fastforce intro: red_reds.intros)
next
case CASThrow thus ?case by(fastforce intro: red_reds.intros)
next
case CASThrow2 thus ?case by(fastforce intro: red_reds.intros)
next
case CASThrow3 thus ?case by(fastforce intro: red_reds.intros)
next
case CallThrowObj thus ?case by(fastforce intro: red_reds.intros)
next
case CallThrowParams thus ?case by(fastforce intro: red_reds.intros)
next
case BlockThrow thus ?case by(fastforce intro: red_reds.intros)
next
case SynchronizedThrow1 thus ?case by(fastforce intro: red_reds.intros)
next
case SynchronizedThrow2 thus ?case by(fastforce intro: red_reds.intros)
next
case SeqThrow thus ?case by(fastforce intro: red_reds.intros)
next
case CondThrow thus ?case by(fastforce intro: red_reds.intros)
next
case ThrowThrow thus ?case by(fastforce intro: red_reds.intros)
qed
lemma can_lock_devreserp:
"⟦ wf_J_prog P; red_mthr.can_sync P t (e, l) h' L; P,E,h ⊢ e : T; P,h ⊢ t √t; hconf h; h ⊴ h' ⟧
⟹ red_mthr.can_sync P t (e, l) h L"
apply(erule red_mthr.can_syncE)
apply(clarsimp)
apply(drule red_wt_hconf_hext, assumption+)
apply(simp)
apply(fastforce intro!: red_mthr.can_syncI)
done
end
context J_typesafe begin
lemma preserve_deadlocked:
assumes wf: "wf_J_prog P"
shows "preserve_deadlocked final_expr (mred P) convert_RA ({s. sync_es_ok (thr s) (shr s) ∧ lock_ok (locks s) (thr s)} ∩ {s. ∃Es. sconf_type_ts_ok Es (thr s) (shr s)} ∩ {s. def_ass_ts_ok (thr s) (shr s)})"
(is "preserve_deadlocked _ _ _ ?wf_state")
proof(unfold_locales)
show inv: "invariant3p (mredT P) ?wf_state"
by(intro invariant3p_IntI invariant3p_sync_es_ok_lock_ok[OF wf] lifting_inv.invariant3p_ts_inv[OF lifting_inv_sconf_subject_ok[OF wf]] lifting_wf.invariant3p_ts_ok[OF lifting_wf_def_ass[OF wf]])
fix s t' ta' s' t x ln
assume wfs: "s ∈ ?wf_state"
and redT: "P ⊢ s -t'▹ta'→ s'"
and tst: "thr s t = ⌊(x, ln)⌋"
from redT have hext: "shr s ⊴ shr s'" by(rule redT_hext_incr)
from inv redT wfs have wfs': "s' ∈ ?wf_state" by(rule invariant3pD)
from redT tst obtain x' ln' where ts't: "thr s' t= ⌊(x', ln')⌋"
by(cases "thr s' t")(cases s, cases s', auto dest: red_mthr.redT_thread_not_disappear)
from wfs tst obtain E T where wt: "P,E,shr s ⊢ fst x : T"
and hconf: "hconf (shr s)"
and da: "𝒟 (fst x) ⌊dom (snd x)⌋"
and tconf: "P,shr s ⊢ t √t"
by(force dest: ts_invD ts_okD simp add: type_ok_def sconf_def sconf_type_ok_def)
from wt hext have wt': "P,E,shr s' ⊢ fst x : T" by(rule WTrt_hext_mono)
from wfs' ts't have hconf': "hconf (shr s')"
by(auto dest: ts_invD simp add: type_ok_def sconf_def sconf_type_ok_def)
{
assume cs: "red_mthr.must_sync P t x (shr s)"
from cs have "¬ final (fst x)" by(auto elim!: red_mthr.must_syncE simp add: split_beta)
from progress[OF wf_prog_wwf_prog[OF wf] hconf' wt' da this, of "extTA2J P" t]
obtain e' h x' ta where "P,t ⊢ ⟨fst x,(shr s', snd x)⟩ -ta→ ⟨e', (h, x')⟩" by auto
with red_ta_satisfiable[OF this]
show "red_mthr.must_sync P t x (shr s')"
by-(rule red_mthr.must_syncI, fastforce simp add: split_beta)
next
fix LT
assume "red_mthr.can_sync P t x (shr s') LT"
with can_lock_devreserp[OF wf _ wt tconf hconf hext, of "snd x" LT]
show "∃LT'⊆LT. red_mthr.can_sync P t x (shr s) LT'" by auto
}
qed
end
end
Theory Annotate
section ‹Program annotation›
theory Annotate
imports
WellType
begin
abbreviation (output)
unanFAcc :: "'addr expr ⇒ vname ⇒ 'addr expr" ("(_∙_)" [10,10] 90)
where
"unanFAcc e F ≡ FAcc e F (STR '''')"
abbreviation (output)
unanFAss :: "'addr expr ⇒ vname ⇒ 'addr expr ⇒ 'addr expr" ("(_∙_ := _)" [10,0,90] 90)
where
"unanFAss e F e' ≡ FAss e F (STR '''') e'"
definition array_length_field_name :: vname
where "array_length_field_name = STR ''length''"
notation (output) array_length_field_name ("length")
definition super :: vname
where "super = STR ''super''"
lemma super_neq_this [simp]: "super ≠ this" "this ≠ super"
by(simp_all add: this_def super_def)
inductive Anno :: "(ty ⇒ ty ⇒ ty ⇒ bool) ⇒ 'addr J_prog ⇒ env ⇒ 'addr expr ⇒ 'addr expr ⇒ bool"
("_,_,_ ⊢ _ ↝ _" [51,51,0,0,51]50)
and Annos :: "(ty ⇒ ty ⇒ ty ⇒ bool) ⇒ 'addr J_prog ⇒ env ⇒ 'addr expr list ⇒ 'addr expr list ⇒ bool"
("_,_,_ ⊢ _ [↝] _" [51,51,0,0,51]50)
for is_lub :: "ty ⇒ ty ⇒ ty ⇒ bool" and P :: "'addr J_prog"
where
AnnoNew: "is_lub,P,E ⊢ new C ↝ new C"
| AnnoNewArray: "is_lub,P,E ⊢ i ↝ i' ⟹ is_lub,P,E ⊢ newA T⌊i⌉ ↝ newA T⌊i'⌉"
| AnnoCast: "is_lub,P,E ⊢ e ↝ e' ⟹ is_lub,P,E ⊢ Cast C e ↝ Cast C e'"
| AnnoInstanceOf: "is_lub,P,E ⊢ e ↝ e' ⟹ is_lub,P,E ⊢ e instanceof T ↝ e' instanceof T"
| AnnoVal: "is_lub,P,E ⊢ Val v ↝ Val v"
| AnnoVarVar: "⟦ E V = ⌊T⌋; V ≠ super ⟧ ⟹ is_lub,P,E ⊢ Var V ↝ Var V"
| AnnoVarField:
"⟦ E V = None; V ≠ super; E this = ⌊Class C⌋; P ⊢ C sees V:T (fm) in D ⟧
⟹ is_lub,P,E ⊢ Var V ↝ Var this∙V{D}"
| AnnoBinOp:
"⟦ is_lub,P,E ⊢ e1 ↝ e1'; is_lub,P,E ⊢ e2 ↝ e2' ⟧
⟹ is_lub,P,E ⊢ e1 «bop» e2 ↝ e1' «bop» e2'"
| AnnoLAssVar:
"⟦ E V = ⌊T⌋; V ≠ super; is_lub,P,E ⊢ e ↝ e' ⟧ ⟹ is_lub,P,E ⊢ V:=e ↝ V:=e'"
| AnnoLAssField:
"⟦ E V = None; V ≠ super; E this = ⌊Class C⌋; P ⊢ C sees V:T (fm) in D; is_lub,P,E ⊢ e ↝ e' ⟧
⟹ is_lub,P,E ⊢ V:=e ↝ Var this∙V{D} := e'"
| AnnoAAcc:
"⟦ is_lub,P,E ⊢ a ↝ a'; is_lub,P,E ⊢ i ↝ i' ⟧ ⟹ is_lub,P,E ⊢ a⌊i⌉ ↝ a'⌊i'⌉"
| AnnoAAss:
"⟦ is_lub,P,E ⊢ a ↝ a'; is_lub,P,E ⊢ i ↝ i'; is_lub,P,E ⊢ e ↝ e' ⟧ ⟹ is_lub,P,E ⊢ a⌊i⌉ := e ↝ a'⌊i'⌉ := e'"
| AnnoALength:
"is_lub,P,E ⊢ a ↝ a' ⟹ is_lub,P,E ⊢ a∙length ↝ a'∙length"
|
AnnoFAcc:
"⟦ is_lub,P,E ⊢ e ↝ e'; is_lub,P,E ⊢ e' :: U; class_type_of' U = ⌊C⌋; P ⊢ C sees F:T (fm) in D;
is_Array U ⟶ F ≠ array_length_field_name ⟧
⟹ is_lub,P,E ⊢ e∙F{STR ''''} ↝ e'∙F{D}"
| AnnoFAccALength:
"⟦ is_lub,P,E ⊢ e ↝ e'; is_lub,P,E ⊢ e' :: T⌊⌉ ⟧
⟹ is_lub,P,E ⊢ e∙array_length_field_name{STR ''''} ↝ e'∙length"
| AnnoFAccSuper:
"⟦ E this = ⌊Class C⌋; C ≠ Object; class P C = ⌊(D, fs, ms)⌋;
P ⊢ D sees F:T (fm) in D' ⟧
⟹ is_lub,P,E ⊢ Var super∙F{STR ''''} ↝ (Cast (Class D) (Var this))∙F{D'}"
| AnnoFAss:
"⟦ is_lub,P,E ⊢ e1 ↝ e1'; is_lub,P,E ⊢ e2 ↝ e2';
is_lub,P,E ⊢ e1' :: U; class_type_of' U = ⌊C⌋; P ⊢ C sees F:T (fm) in D;
is_Array U ⟶ F ≠ array_length_field_name ⟧
⟹ is_lub,P,E ⊢ e1∙F{STR ''''} := e2 ↝ e1'∙F{D} := e2'"
| AnnoFAssSuper:
"⟦ E this = ⌊Class C⌋; C ≠ Object; class P C = ⌊(D, fs, ms)⌋;
P ⊢ D sees F:T (fm) in D'; is_lub,P,E ⊢ e ↝ e' ⟧
⟹ is_lub,P,E ⊢ Var super∙F{STR ''''} := e ↝ (Cast (Class D) (Var this))∙F{D'} := e'"
| AnnoCAS:
"⟦ is_lub,P,E ⊢ e1 ↝ e1'; is_lub,P,E ⊢ e2 ↝ e2'; is_lub,P,E ⊢ e3 ↝ e3' ⟧
⟹ is_lub,P,E ⊢ e1∙compareAndSwap(D∙F, e2, e3) ↝ e1'∙compareAndSwap(D∙F, e2', e3')"
| AnnoCall:
"⟦ is_lub,P,E ⊢ e ↝ e'; is_lub,P,E ⊢ es [↝] es' ⟧
⟹ is_lub,P,E ⊢ Call e M es ↝ Call e' M es'"
| AnnoBlock:
"is_lub,P,E(V ↦ T) ⊢ e ↝ e' ⟹ is_lub,P,E ⊢ {V:T=vo; e} ↝ {V:T=vo; e'}"
| AnnoSync:
"⟦ is_lub,P,E ⊢ e1 ↝ e1'; is_lub,P,E ⊢ e2 ↝ e2' ⟧
⟹ is_lub,P,E ⊢ sync(e1) e2 ↝ sync(e1') e2'"
| AnnoComp:
"⟦ is_lub,P,E ⊢ e1 ↝ e1'; is_lub,P,E ⊢ e2 ↝ e2' ⟧
⟹ is_lub,P,E ⊢ e1;;e2 ↝ e1';;e2'"
| AnnoCond:
"⟦ is_lub,P,E ⊢ e ↝ e'; is_lub,P,E ⊢ e1 ↝ e1'; is_lub,P,E ⊢ e2 ↝ e2' ⟧
⟹ is_lub,P,E ⊢ if (e) e1 else e2 ↝ if (e') e1' else e2'"
| AnnoLoop:
"⟦ is_lub,P,E ⊢ e ↝ e'; is_lub,P,E ⊢ c ↝ c' ⟧
⟹ is_lub,P,E ⊢ while (e) c ↝ while (e') c'"
| AnnoThrow:
"is_lub,P,E ⊢ e ↝ e' ⟹ is_lub,P,E ⊢ throw e ↝ throw e'"
| AnnoTry:
"⟦ is_lub,P,E ⊢ e1 ↝ e1'; is_lub,P,E(V ↦ Class C) ⊢ e2 ↝ e2' ⟧
⟹ is_lub,P,E ⊢ try e1 catch(C V) e2 ↝ try e1' catch(C V) e2'"
| AnnoNil:
"is_lub,P,E ⊢ [] [↝] []"
| AnnoCons:
"⟦ is_lub,P,E ⊢ e ↝ e'; is_lub,P,E ⊢ es [↝] es' ⟧ ⟹ is_lub,P,E ⊢ e#es [↝] e'#es'"
inductive_cases Anno_cases [elim!]:
"is_lub',P,E ⊢ new C ↝ e"
"is_lub',P,E ⊢ newA T⌊e⌉ ↝ e'"
"is_lub',P,E ⊢ Cast T e ↝ e'"
"is_lub',P,E ⊢ e instanceof T ↝ e'"
"is_lub',P,E ⊢ Val v ↝ e'"
"is_lub',P,E ⊢ Var V ↝ e'"
"is_lub',P,E ⊢ e1 «bop» e2 ↝ e'"
"is_lub',P,E ⊢ V := e ↝ e'"
"is_lub',P,E ⊢ e1⌊e2⌉ ↝ e'"
"is_lub',P,E ⊢ e1⌊e2⌉ := e3 ↝ e'"
"is_lub',P,E ⊢ e∙length ↝ e'"
"is_lub',P,E ⊢ e∙F{D} ↝ e'"
"is_lub',P,E ⊢ e1∙F{D} := e2 ↝ e'"
"is_lub',P,E ⊢ e1∙compareAndSwap(D∙F, e2, e3) ↝ e'"
"is_lub',P,E ⊢ e∙M(es) ↝ e'"
"is_lub',P,E ⊢ {V:T=vo; e} ↝ e'"
"is_lub',P,E ⊢ sync(e1) e2 ↝ e'"
"is_lub',P,E ⊢ insync(a) e2 ↝ e'"
"is_lub',P,E ⊢ e1;; e2 ↝ e'"
"is_lub',P,E ⊢ if (e) e1 else e2 ↝ e'"
"is_lub',P,E ⊢ while(e1) e2 ↝ e'"
"is_lub',P,E ⊢ throw e ↝ e'"
"is_lub',P,E ⊢ try e1 catch(C V) e2 ↝ e'"
inductive_cases Annos_cases [elim!]:
"is_lub',P,E ⊢ [] [↝] es'"
"is_lub',P,E ⊢ e # es [↝] es'"
abbreviation Anno' :: "'addr J_prog ⇒ env ⇒ 'addr expr ⇒ 'addr expr ⇒ bool" ("_,_ ⊢ _ ↝ _" [51,0,0,51]50)
where "Anno' P ≡ Anno (TypeRel.is_lub P) P"
abbreviation Annos' :: "'addr J_prog ⇒ env ⇒ 'addr expr list ⇒ 'addr expr list ⇒ bool" ("_,_ ⊢ _ [↝] _" [51,0,0,51]50)
where "Annos' P ≡ Annos (TypeRel.is_lub P) P"
definition annotate :: "'addr J_prog ⇒ env ⇒ 'addr expr ⇒ 'addr expr"
where "annotate P E e = THE_default e (λe'. P,E ⊢ e ↝ e')"
lemma fixes is_lub :: "ty ⇒ ty ⇒ ty ⇒ bool" ("⊢ lub'((_,/ _)') = _" [51,51,51] 50)
assumes is_lub_unique: "⋀T1 T2 T3 T4. ⟦ ⊢ lub(T1, T2) = T3; ⊢ lub(T1, T2) = T4 ⟧ ⟹ T3 = T4"
shows Anno_fun: "⟦ is_lub,P,E ⊢ e ↝ e'; is_lub,P,E ⊢ e ↝ e'' ⟧ ⟹ e' = e''"
and Annos_fun: "⟦ is_lub,P,E ⊢ es [↝] es'; is_lub,P,E ⊢ es [↝] es'' ⟧ ⟹ es' = es''"
proof(induct arbitrary: e'' and es'' rule: Anno_Annos.inducts)
case (AnnoFAcc E e e' U C F T fm D)
from ‹is_lub,P,E ⊢ e∙F{STR ''''} ↝ e''› show ?case
proof(rule Anno_cases)
fix e''' U' C' T' fm' D'
assume "is_lub,P,E ⊢ e ↝ e'''" "is_lub,P,E ⊢ e''' :: U'"
and "class_type_of' U' = ⌊C'⌋"
and "P ⊢ C' sees F:T' (fm') in D'" "e'' = e'''∙F{D'}"
from ‹is_lub,P,E ⊢ e ↝ e'''› have "e' = e'''" by(rule AnnoFAcc)
with ‹is_lub,P,E ⊢ e' :: U› ‹is_lub,P,E ⊢ e''' :: U'›
have "U = U'" by(auto intro: WT_unique is_lub_unique)
with ‹class_type_of' U = ⌊C⌋› ‹class_type_of' U' = ⌊C'⌋›
have "C = C'" by(auto)
with ‹P ⊢ C' sees F:T' (fm') in D'› ‹P ⊢ C sees F:T (fm) in D›
have "D' = D" by(auto dest: sees_field_fun)
with ‹e'' = e'''∙F{D'}› ‹e' = e'''› show ?thesis by simp
next
fix e''' T
assume "e'' = e'''∙length"
and "is_lub,P,E ⊢ e''' :: T⌊⌉"
and "is_lub,P,E ⊢ e ↝ e'''"
and "F = array_length_field_name"
from ‹is_lub,P,E ⊢ e ↝ e'''› have "e' = e'''" by(rule AnnoFAcc)
with ‹is_lub,P,E ⊢ e' :: U› ‹is_lub,P,E ⊢ e''' :: T⌊⌉› have "U = T⌊⌉" by(auto intro: WT_unique is_lub_unique)
with ‹class_type_of' U = ⌊C⌋› ‹is_Array U ⟶ F ≠ array_length_field_name›
show ?thesis using ‹F = array_length_field_name› by simp
next
fix C' D' fs ms T D''
assume "E this = ⌊Class C'⌋"
and "class P C' = ⌊(D', fs, ms)⌋"
and "e = Var super"
and "e'' = Cast (Class D') (Var this)∙F{D''}"
with ‹is_lub,P,E ⊢ e ↝ e'› have False by(auto)
thus ?thesis ..
qed
next
case AnnoFAccALength thus ?case by(fastforce intro: WT_unique[OF is_lub_unique])
next
case (AnnoFAss E e1 e1' e2 e2' U C F T fm D)
from ‹is_lub,P,E ⊢ e1∙F{STR ''''} := e2 ↝ e''›
show ?case
proof(rule Anno_cases)
fix e1'' e2'' U' C' T' fm' D'
assume "is_lub,P,E ⊢ e1 ↝ e1''" "is_lub,P,E ⊢ e2 ↝ e2''"
and "is_lub,P,E ⊢ e1'' :: U'" and "class_type_of' U' = ⌊C'⌋"
and "P ⊢ C' sees F:T' (fm') in D'"
and "e'' = e1''∙F{D'} := e2''"
from ‹is_lub,P,E ⊢ e1 ↝ e1''› have "e1' = e1''" by(rule AnnoFAss)
moreover with ‹is_lub,P,E ⊢ e1' :: U› ‹is_lub,P,E ⊢ e1'' :: U'›
have "U = U'" by(auto intro: WT_unique is_lub_unique)
with ‹class_type_of' U = ⌊C⌋› ‹class_type_of' U' = ⌊C'⌋›
have "C = C'" by(auto)
with ‹P ⊢ C' sees F:T' (fm') in D'› ‹P ⊢ C sees F:T (fm) in D›
have "D' = D" by(auto dest: sees_field_fun)
moreover from ‹is_lub,P,E ⊢ e2 ↝ e2''› have "e2' = e2''" by(rule AnnoFAss)
ultimately show ?thesis using ‹e'' = e1''∙F{D'} := e2''› by simp
next
fix C' D' fs ms T' fm' D'' e'''
assume "e'' = Cast (Class D') (Var this)∙F{D''} := e'''"
and "E this = ⌊Class C'⌋"
and "class P C' = ⌊(D', fs, ms)⌋"
and "P ⊢ D' sees F:T' (fm') in D''"
and "is_lub,P,E ⊢ e2 ↝ e'''"
and "e1 = Var super"
with ‹is_lub,P,E ⊢ e1 ↝ e1'› have False by(auto elim: Anno_cases)
thus ?thesis ..
qed
qed(fastforce dest: sees_field_fun)+
subsection ‹Code generation›
definition Anno_code :: "'addr J_prog ⇒ env ⇒ 'addr expr ⇒ 'addr expr ⇒ bool" ("_,_ ⊢ _ ↝'' _" [51,0,0,51]50)
where "Anno_code P = Anno (is_lub_sup P) P"
definition Annos_code :: "'addr J_prog ⇒ env ⇒ 'addr expr list ⇒ 'addr expr list ⇒ bool" ("_,_ ⊢ _ [↝''] _" [51,0,0,51]50)
where "Annos_code P = Annos (is_lub_sup P) P"
primrec block_types :: "('a, 'b, 'addr) exp ⇒ ty list"
and blocks_types :: "('a, 'b, 'addr) exp list ⇒ ty list"
where
"block_types (new C) = []"
| "block_types (newA T⌊e⌉) = block_types e"
| "block_types (Cast U e) = block_types e"
| "block_types (e instanceof U) = block_types e"
| "block_types (e1«bop»e2) = block_types e1 @ block_types e2"
| "block_types (Val v) = []"
| "block_types (Var V) = []"
| "block_types (V := e) = block_types e"
| "block_types (a⌊i⌉) = block_types a @ block_types i"
| "block_types (a⌊i⌉ := e) = block_types a @ block_types i @ block_types e"
| "block_types (a∙length) = block_types a"
| "block_types (e∙F{D}) = block_types e"
| "block_types (e∙F{D} := e') = block_types e @ block_types e'"
| "block_types (e∙compareAndSwap(D∙F, e', e'')) = block_types e @ block_types e' @ block_types e''"
| "block_types (e∙M(es)) = block_types e @ blocks_types es"
| "block_types {V:T=vo; e} = T # block_types e"
| "block_types (sync⇘V⇙(e) e') = block_types e @ block_types e'"
| "block_types (insync⇘V⇙(a) e) = block_types e"
| "block_types (e;;e') = block_types e @ block_types e'"
| "block_types (if (e) e1 else e2) = block_types e @ block_types e1 @ block_types e2"
| "block_types (while (b) c) = block_types b @ block_types c"
| "block_types (throw e) = block_types e"
| "block_types (try e catch(C V) e') = block_types e @ Class C # block_types e'"
| "blocks_types [] = []"
| "blocks_types (e#es) = block_types e @ blocks_types es"
lemma fixes is_lub1 :: "ty ⇒ ty ⇒ ty ⇒ bool" ("⊢1 lub'((_,/ _)') = _" [51,51,51] 50)
and is_lub2 :: "ty ⇒ ty ⇒ ty ⇒ bool" ("⊢2 lub'((_,/ _)') = _" [51,51,51] 50)
assumes wf: "wf_prog wf_md P"
and is_lub1_into_is_lub2: "⋀T1 T2 T3. ⟦ ⊢1 lub(T1, T2) = T3; is_type P T1; is_type P T2 ⟧ ⟹ ⊢2 lub(T1, T2) = T3"
and is_lub2_is_type: "⋀T1 T2 T3. ⟦ ⊢2 lub(T1, T2) = T3; is_type P T1; is_type P T2 ⟧ ⟹ is_type P T3"
shows Anno_change_is_lub:
"⟦ is_lub1,P,E ⊢ e ↝ e'; ran E ∪ set (block_types e) ⊆ types P ⟧ ⟹ is_lub2,P,E ⊢ e ↝ e'"
and Annos_change_is_lub:
"⟦ is_lub1,P,E ⊢ es [↝] es'; ran E ∪ set (blocks_types es) ⊆ types P ⟧ ⟹ is_lub2,P,E ⊢ es [↝] es'"
proof(induct rule: Anno_Annos.inducts)
case (AnnoBlock E V T e e' vo)
from ‹ran E ∪ set (block_types {V:T=vo; e}) ⊆ types P›
have "ran (E(V ↦ T)) ∪ set (block_types e) ⊆ types P"
by(auto simp add: ran_def)
thus ?case using AnnoBlock by(blast intro: Anno_Annos.intros)
next
case (AnnoTry E e1 e1' V C e2 e2')
from ‹ran E ∪ set (block_types (try e1 catch(C V) e2)) ⊆ types P›
have "ran (E(V ↦ Class C)) ∪ set (block_types e2) ⊆ types P"
by(auto simp add: ran_def)
thus ?case using AnnoTry by(simp del: fun_upd_apply)(blast intro: Anno_Annos.intros)
qed(simp_all del: is_Array.simps is_Array_conv, (blast intro: Anno_Annos.intros WT_change_is_lub[OF wf, where ?is_lub1.0=is_lub1 and ?is_lub2.0=is_lub2] is_lub1_into_is_lub2 is_lub2_is_type)+)
lemma assumes wf: "wf_prog wf_md P"
shows Anno_into_Anno_code: "⟦ P,E ⊢ e ↝ e'; ran E ∪ set (block_types e) ⊆ types P ⟧ ⟹ P,E ⊢ e ↝' e'"
and Annos_into_Annos_code: "⟦ P,E ⊢ es [↝] es'; ran E ∪ set (blocks_types es) ⊆ types P ⟧ ⟹ P,E ⊢ es [↝'] es'"
proof -
assume anno: "P,E ⊢ e ↝ e'"
and ran: "ran E ∪ set (block_types e) ⊆ types P"
show "P,E ⊢ e ↝' e'" unfolding Anno_code_def
by(rule Anno_change_is_lub[OF wf _ _ anno ran])(blast intro!: is_lub_sup.intros intro: is_lub_subD[OF wf] sup_is_type[OF wf] elim!: is_lub_sup.cases)+
next
assume annos: "P,E ⊢ es [↝] es'"
and ran: "ran E ∪ set (blocks_types es) ⊆ types P"
show "P,E ⊢ es [↝'] es'" unfolding Annos_code_def
by(rule Annos_change_is_lub[OF wf _ _ annos ran])(blast intro!: is_lub_sup.intros intro: is_lub_subD[OF wf] sup_is_type[OF wf] elim!: is_lub_sup.cases)+
qed
lemma assumes wf: "wf_prog wf_md P"
shows Anno_code_into_Anno: "⟦ P,E ⊢ e ↝' e'; ran E ∪ set (block_types e) ⊆ types P ⟧ ⟹ P,E ⊢ e ↝ e'"
and Annos_code_into_Annos: "⟦ P,E ⊢ es [↝'] es'; ran E ∪ set (blocks_types es) ⊆ types P ⟧ ⟹ P,E ⊢ es [↝] es'"
proof -
assume anno: "P,E ⊢ e ↝' e'"
and ran: "ran E ∪ set (block_types e) ⊆ types P"
show "P,E ⊢ e ↝ e'"
by(rule Anno_change_is_lub[OF wf _ _ anno[unfolded Anno_code_def] ran])(blast elim!: is_lub_sup.cases intro: sup_is_lubI[OF wf] is_lub_is_type[OF wf])+
next
assume annos: "P,E ⊢ es [↝'] es'"
and ran: "ran E ∪ set (blocks_types es) ⊆ types P"
show "P,E ⊢ es [↝] es'"
by(rule Annos_change_is_lub[OF wf _ _ annos[unfolded Annos_code_def] ran])(blast elim!: is_lub_sup.cases intro: sup_is_lubI[OF wf] is_lub_is_type[OF wf])+
qed
lemma fixes is_lub
assumes wf: "wf_prog wf_md P"
shows WT_block_types_is_type: "is_lub,P,E ⊢ e :: T ⟹ set (block_types e) ⊆ types P"
and WTs_blocks_types_is_type: "is_lub,P,E ⊢ es [::] Ts ⟹ set (blocks_types es) ⊆ types P"
apply(induct rule: WT_WTs.inducts)
apply(auto intro: is_class_sub_Throwable[OF wf])
done
lemma fixes is_lub
shows Anno_block_types: "is_lub,P,E ⊢ e ↝ e' ⟹ block_types e = block_types e'"
and Annos_blocks_types: "is_lub,P,E ⊢ es [↝] es' ⟹ blocks_types es = blocks_types es'"
by(induct rule: Anno_Annos.inducts) auto
code_pred
(modes: (i ⇒ i ⇒ o ⇒ bool) ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool)
[detect_switches, skip_proof]
Anno
.
definition annotate_code :: "'addr J_prog ⇒ env ⇒ 'addr expr ⇒ 'addr expr"
where "annotate_code P E e = THE_default e (λe'. P,E ⊢ e ↝' e')"
code_pred
(modes: i ⇒ i ⇒ i ⇒ o ⇒ bool)
[inductify]
Anno_code
.
lemma eval_Anno_i_i_i_o_conv:
"Predicate.eval (Anno_code_i_i_i_o P E e) = (λe'. P,E ⊢ e ↝' e')"
by(auto intro!: ext intro: Anno_code_i_i_i_oI elim: Anno_code_i_i_i_oE)
lemma annotate_code [code]:
"annotate_code P E e = Predicate.singleton (λ_. Code.abort (STR ''annotate'') (λ_. e)) (Anno_code_i_i_i_o P E e)"
by(simp add: THE_default_def Predicate.singleton_def annotate_code_def eval_Anno_i_i_i_o_conv)
end
Theory J_Main
theory J_Main
imports
State
Deadlocked
Annotate
begin
end
Theory JVMState
chapter ‹Jinja Virtual Machine \label{cha:jvm}›
section ‹State of the JVM›
theory JVMState
imports
"../Common/Observable_Events"
begin
subsection ‹Frame Stack›
type_synonym
pc = nat
type_synonym
'addr frame = "'addr val list × 'addr val list × cname × mname × pc"
print_translation ‹
let
fun tr'
[Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "val"}, _) $ a1),
Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "val"}, _) $ a2)) $
(Const (@{type_syntax "prod"}, _) $
Const (@{type_syntax "String.literal"}, _) $
(Const (@{type_syntax "prod"}, _) $
Const (@{type_syntax "String.literal"}, _) $
Const (@{type_syntax "nat"}, _)))] =
if a1 = a2 then Syntax.const @{type_syntax "frame"} $ a1
else raise Match;
in [(@{type_syntax "prod"}, K tr')]
end
›
typ "'addr frame"
subsection ‹Runtime State›
type_synonym
('addr, 'heap) jvm_state = "'addr option × 'heap × 'addr frame list"
type_synonym
'addr jvm_thread_state = "'addr option × 'addr frame list"
type_synonym
('addr, 'thread_id, 'heap) jvm_thread_action = "('addr, 'thread_id, 'addr jvm_thread_state,'heap) Jinja_thread_action"
type_synonym
('addr, 'thread_id, 'heap) jvm_ta_state = "('addr, 'thread_id, 'heap) jvm_thread_action × ('addr, 'heap) jvm_state"
print_translation ‹
let
fun tr'
[a1, t
, Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax "option"}, _) $ a2) $
(Const (@{type_syntax "list"}, _) $
(Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "val"}, _) $ a3)) $
(Const (@{type_syntax "prod"}, _) $
(Const (@{type_syntax "list"}, _) $ (Const (@{type_syntax "val"}, _) $ a4)) $
(Const (@{type_syntax "prod"}, _) $
Const (@{type_syntax "String.literal"}, _) $
(Const (@{type_syntax "prod"}, _) $
Const (@{type_syntax "String.literal"}, _) $
Const (@{type_syntax "nat"}, _))))))
, h] =
if a1 = a2 andalso a2 = a3 andalso a3 = a4 then Syntax.const @{type_syntax "jvm_thread_action"} $ a1 $ t $ h
else raise Match;
in [(@{type_syntax "Jinja_thread_action"}, K tr')]
end
›
typ "('addr, 'thread_id, 'heap) jvm_thread_action"
end
Theory JVMInstructions
section ‹Instructions of the JVM›
theory JVMInstructions
imports
JVMState
"../Common/BinOp"
begin
datatype 'addr instr
= Load nat
| Store nat
| Push "'addr val"
| New cname
| NewArray ty
| ALoad
| AStore
| ALength
| Getfield vname cname
| Putfield vname cname
| CAS vname cname
| Checkcast ty
| Instanceof ty
| Invoke mname nat
| Return
| Pop
| Dup
| Swap
| BinOpInstr bop
| Goto int
| IfFalse int
| ThrowExc
| MEnter
| MExit
abbreviation CmpEq :: "'addr instr"
where "CmpEq ≡ BinOpInstr Eq"
abbreviation CmpLeq :: "'addr instr"
where "CmpLeq ≡ BinOpInstr LessOrEqual"
abbreviation CmpGeq :: "'addr instr"
where "CmpGeq ≡ BinOpInstr GreaterOrEqual"
abbreviation CmpLt :: "'addr instr"
where "CmpLt ≡ BinOpInstr LessThan"
abbreviation CmpGt :: "'addr instr"
where "CmpGt ≡ BinOpInstr GreaterThan"
abbreviation IAdd :: "'addr instr"
where "IAdd ≡ BinOpInstr Add"
abbreviation ISub :: "'addr instr"
where "ISub ≡ BinOpInstr Subtract"
abbreviation IMult :: "'addr instr"
where "IMult ≡ BinOpInstr Mult"
abbreviation IDiv :: "'addr instr"
where "IDiv ≡ BinOpInstr Div"
abbreviation IMod :: "'addr instr"
where "IMod ≡ BinOpInstr Mod"
abbreviation IShl :: "'addr instr"
where "IShl ≡ BinOpInstr ShiftLeft"
abbreviation IShr :: "'addr instr"
where "IShr ≡ BinOpInstr ShiftRightSigned"
abbreviation IUShr :: "'addr instr"
where "IUShr ≡ BinOpInstr ShiftRightZeros"
abbreviation IAnd :: "'addr instr"
where "IAnd ≡ BinOpInstr BinAnd"
abbreviation IOr :: "'addr instr"
where "IOr ≡ BinOpInstr BinOr"
abbreviation IXor :: "'addr instr"
where "IXor ≡ BinOpInstr BinXor"
type_synonym
'addr bytecode = "'addr instr list"
type_synonym
ex_entry = "pc × pc × cname option × pc × nat"
type_synonym
ex_table = "ex_entry list"
type_synonym
'addr jvm_method = "nat × nat × 'addr bytecode × ex_table"
type_synonym
'addr jvm_prog = "'addr jvm_method prog"
end
Theory JVMHeap
section ‹Abstract heap locales for byte code programs›
theory JVMHeap
imports
"../Common/Conform"
JVMInstructions
begin
locale JVM_heap_base =
heap_base +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
locale JVM_heap =
JVM_heap_base +
heap +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and P :: "'addr jvm_prog"
locale JVM_heap_conf_base =
heap_conf_base +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and hconf :: "'heap ⇒ bool"
and P :: "'addr jvm_prog"
sublocale JVM_heap_conf_base < JVM_heap_base .
locale JVM_heap_conf_base' =
JVM_heap_conf_base +
heap +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and hconf :: "'heap ⇒ bool"
and P :: "'addr jvm_prog"
sublocale JVM_heap_conf_base' < JVM_heap by(unfold_locales)
locale JVM_heap_conf =
JVM_heap_conf_base' +
heap_conf +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and hconf :: "'heap ⇒ bool"
and P :: "'addr jvm_prog"
locale JVM_progress =
heap_progress +
JVM_heap_conf_base' +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and hconf :: "'heap ⇒ bool"
and P :: "'addr jvm_prog"
locale JVM_conf_read =
heap_conf_read +
JVM_heap_conf +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and hconf :: "'heap ⇒ bool"
and P :: "'addr jvm_prog"
locale JVM_typesafe =
heap_typesafe +
JVM_conf_read +
JVM_progress +
constrains addr2thread_id :: "('addr :: addr) ⇒ 'thread_id"
and thread_id2addr :: "'thread_id ⇒ 'addr"
and spurious_wakeups :: bool
and empty_heap :: "'heap"
and allocate :: "'heap ⇒ htype ⇒ ('heap × 'addr) set"
and typeof_addr :: "'heap ⇒ 'addr ⇀ htype"
and heap_read :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ bool"
and heap_write :: "'heap ⇒ 'addr ⇒ addr_loc ⇒ 'addr val ⇒ 'heap ⇒ bool"
and hconf :: "'heap ⇒ bool"
and P :: "'addr jvm_prog"
end
Theory JVMExecInstr
section ‹JVM Instruction Semantics›
theory JVMExecInstr
imports
JVMInstructions
JVMHeap
"../Common/ExternalCall"
begin
primrec extRet2JVM ::
"nat ⇒ 'heap ⇒ 'addr val list ⇒ 'addr val list ⇒ cname ⇒ mname ⇒ pc ⇒ 'addr frame list
⇒ 'addr extCallRet ⇒ ('addr, 'heap) jvm_state"
where
"extRet2JVM n h stk loc C M pc frs (RetVal v) = (None, h, (v # drop (Suc n) stk, loc, C, M, pc + 1) # frs)"
| "extRet2JVM n h stk loc C M pc frs (RetExc a) = (⌊a⌋, h, (stk, loc, C, M, pc) # frs)"
| "extRet2JVM n h stk loc C M pc frs RetStaySame = (None, h, (stk, loc, C, M, pc) # frs)"
lemma eq_extRet2JVM_conv [simp]:
"(xcp, h', frs') = extRet2JVM n h stk loc C M pc frs va ⟷
h' = h ∧ (case va of RetVal v ⇒ xcp = None ∧ frs' = (v # drop (Suc n) stk, loc, C, M, pc + 1) # frs
| RetExc a ⇒ xcp = ⌊a⌋ ∧ frs' = (stk, loc, C, M, pc) # frs
| RetStaySame ⇒ xcp = None ∧ frs' = (stk, loc, C, M, pc) # frs)"
by(cases va) auto
definition extNTA2JVM :: "'addr jvm_prog ⇒ (cname × mname × 'addr) ⇒ 'addr jvm_thread_state"
where "extNTA2JVM P ≡ (λ(C, M, a). let (D,M',Ts,meth) = method P C M; (mxs,mxl0,ins,xt) = the meth
in (None, [([],Addr a # replicate mxl0 undefined_value, D, M, 0)]))"
abbreviation extTA2JVM ::
"'addr jvm_prog ⇒ ('addr, 'thread_id, 'heap) external_thread_action ⇒ ('addr, 'thread_id, 'heap) jvm_thread_action"
where "extTA2JVM P ≡ convert_extTA (extNTA2JVM P)"
context JVM_heap_base begin
primrec exec_instr ::
"'addr instr ⇒ 'addr jvm_prog ⇒ 'thread_id ⇒ 'heap ⇒ 'addr val list ⇒ 'addr val list
⇒ cname ⇒ mname ⇒ pc ⇒ 'addr frame list ⇒
(('addr, 'thread_id, 'heap) jvm_thread_action × ('addr, 'heap) jvm_state) set"
where
exec_instr_Load:
"exec_instr (Load n) P t h stk loc C⇩0 M⇩0 pc frs =
{(ε, (None, h, ((loc ! n) # stk, loc, C⇩0, M⇩0, pc+1)#frs))}"
| "exec_instr (Store n) P t h stk loc C⇩0 M⇩0 pc frs =
{(ε, (None, h, (tl stk, loc[n:=hd stk], C⇩0, M⇩0, pc+1)#frs))}"
| exec_instr_Push:
"exec_instr (Push v) P t h stk loc C⇩0 M⇩0 pc frs =
{(ε, (None, h, (v # stk, loc, C⇩0, M⇩0, pc+1)#frs))}"
| exec_instr_New:
"exec_instr (New C) P t h stk loc C⇩0 M⇩0 pc frs =
(let HA = allocate h (Class_type C)
in if HA = {} then {(ε, ⌊addr_of_sys_xcpt OutOfMemory⌋, h, (stk, loc, C⇩0, M⇩0, pc) # frs)}
else (λ(h', a). (⦃NewHeapElem a (Class_type C)⦄, None, h', (Addr a # stk, loc, C⇩0, M⇩0, pc + 1)#frs)) ` HA)"
| exec_instr_NewArray:
"exec_instr (NewArray T) P t h stk loc C0 M0 pc frs =
(let si = the_Intg (hd stk);
i = nat (sint si)
in (if si <s 0
then {(ε, ⌊addr_of_sys_xcpt NegativeArraySize⌋, h, (stk, loc, C0, M0, pc) # frs)}
else let HA = allocate h (Array_type T i)
in if HA = {} then {(ε, ⌊addr_of_sys_xcpt OutOfMemory⌋, h, (stk, loc, C0, M0, pc) # frs)}
else (λ(h', a). (⦃NewHeapElem a (Array_type T i)⦄, None, h', (Addr a # tl stk, loc, C0, M0, pc + 1) # frs)) ` HA))"
| exec_instr_ALoad:
"exec_instr ALoad P t h stk loc C0 M0 pc frs =
(let i = the_Intg (hd stk);
va = hd (tl stk);
a = the_Addr va;
len = alen_of_htype (the (typeof_addr h a))
in (if va = Null then {(ε, ⌊addr_of_sys_xcpt NullPointer⌋, h, (stk, loc, C0, M0, pc) # frs)}
else if i <s 0 ∨ int len ≤ sint i then
{(ε, ⌊addr_of_sys_xcpt ArrayIndexOutOfBounds⌋, h, (stk, loc, C0, M0, pc) # frs)}
else {(⦃ReadMem a (ACell (nat (sint i))) v⦄, None, h, (v # tl (tl stk), loc, C0, M0, pc + 1) # frs) | v.
heap_read h a (ACell (nat (sint i))) v }))"
| exec_instr_AStore:
"exec_instr AStore P t h stk loc C0 M0 pc frs =
(let ve = hd stk;
vi = hd (tl stk);
va = hd (tl (tl stk))
in (if va = Null then {(ε, ⌊addr_of_sys_xcpt NullPointer⌋, h, (stk, loc, C0, M0, pc) # frs)}
else (let i = the_Intg vi;
idx = nat (sint i);
a = the_Addr va;
hT = the (typeof_addr h a);
T = ty_of_htype hT;
len = alen_of_htype hT;
U = the (typeof⇘h⇙ ve)
in (if i <s 0 ∨ int len ≤ sint i then
{(ε, ⌊addr_of_sys_xcpt ArrayIndexOutOfBounds⌋, h, (stk, loc, C0, M0, pc) # frs)}
else if P ⊢ U ≤ the_Array T then
{(⦃WriteMem a (ACell idx) ve⦄, None, h', (tl (tl (tl stk)), loc, C0, M0, pc+1) # frs)
| h'. heap_write h a (ACell idx) ve h'}
else {(ε, (⌊addr_of_sys_xcpt ArrayStore⌋, h, (stk, loc, C0, M0, pc) # frs))}))))"
| exec_instr_ALength:
"exec_instr ALength P t h stk loc C0 M0 pc frs =
{(ε, (let va = hd stk
in if va = Null
then (⌊addr_of_sys_xcpt NullPointer⌋, h, (stk, loc, C0, M0, pc) # frs)
else (None, h, (Intg (word_of_int (int (alen_of_htype (the (typeof_addr h (the_Addr va)))))) # tl stk, loc, C0, M0, pc+1) # frs)))}"
| "exec_instr (Getfield F C) P t h stk loc C⇩0 M⇩0 pc frs =
(let v = hd stk
in if v = Null then {(ε, ⌊addr_of_sys_xcpt NullPointer⌋, h, (stk, loc, C⇩0, M⇩0, pc) # frs)}
else let a = the_Addr v
in {(⦃ReadMem a (CField C F) v'⦄, None, h, (v' # (tl stk), loc, C⇩0, M⇩0, pc + 1) # frs) | v'.
heap_read h a (CField C F) v'})"
| "exec_instr (Putfield F C) P t h stk loc C⇩0 M⇩0 pc frs =
(let v = hd stk;
r = hd (tl stk)
in if r = Null then {(ε, ⌊addr_of_sys_xcpt NullPointer⌋, h, (stk, loc, C⇩0, M⇩0, pc) # frs)}
else let a = the_Addr r
in {(⦃WriteMem a (CField C F) v⦄, None, h', (tl (tl stk), loc, C⇩0, M⇩0, pc + 1) # frs) | h'.
heap_write h a (CField C F) v h'})"
| "exec_instr (CAS F C) P t h stk loc C0 M0 pc frs =
(let v'' = hd stk; v' = hd (tl stk); v = hd (tl (tl stk))
in if v = Null then {(ε, ⌊addr_of_sys_xcpt NullPointer⌋, h, (stk, loc, C0, M0, pc) # frs)}
else let a = the_Addr v
in {(⦃ReadMem a (CField C F) v', WriteMem a (CField C F) v''⦄, None, h', (Bool True # tl (tl (tl stk)), loc, C0, M0, pc + 1) # frs) | h' .
heap_read h a (CField C F) v' ∧ heap_write h a (CField C F) v'' h'} ∪
{(⦃ReadMem a (CField C F) v''⦄, None, h, (Bool False # tl (tl (tl stk)), loc, C0, M0, pc + 1) # frs) | v''.
heap_read h a (CField C F) v'' ∧ v'' ≠ v'})"
| "exec_instr (Checkcast T) P t h stk loc C⇩0 M⇩0 pc frs =
{(ε, let U = the (typeof⇘h⇙ (hd stk))
in if P ⊢ U ≤ T then (None, h, (stk, loc, C⇩0, M⇩0, pc + 1) # frs)
else (⌊addr_of_sys_xcpt ClassCast⌋, h, (stk, loc, C⇩0, M⇩0, pc) # frs))}"
| "exec_instr (Instanceof T) P t h stk loc C⇩0 M⇩0 pc frs =
{(ε, None, h, (Bool (hd stk ≠ Null ∧ P ⊢ the (typeof⇘h⇙ (hd stk)) ≤ T) # tl stk, loc, C⇩0, M⇩0, pc + 1) # frs)}"
| exec_instr_Invoke:
"exec_instr (Invoke M n) P t h stk loc C0 M0 pc frs =
(let ps = rev (take n stk);
r = stk ! n;
a = the_Addr r;
T = the (typeof_addr h a)
in (if r = Null then {(ε, ⌊addr_of_sys_xcpt NullPointer⌋, h, (stk, loc, C0, M0, pc) # frs)}
else
let C = class_type_of T;
(D,M',Ts,meth)= method P C M
in case meth of
Native ⇒
{(extTA2JVM P ta, extRet2JVM n h' stk loc C0 M0 pc frs va) | ta va h'.
(ta, va, h') ∈ red_external_aggr P t a M ps h}
| ⌊(mxs,mxl⇩0,ins,xt)⌋ ⇒
let f' = ([],[r]@ps@(replicate mxl⇩0 undefined_value),D,M,0)
in {(ε, None, h, f' # (stk, loc, C0, M0, pc) # frs)}))"
| "exec_instr Return P t h stk⇩0 loc⇩0 C⇩0 M⇩0 pc frs =
{(ε, (if frs=[] then (None, h, []) else
let v = hd stk⇩0;
(stk,loc,C,m,pc) = hd frs;
n = length (fst (snd (method P C⇩0 M⇩0)))
in (None, h, (v#(drop (n+1) stk),loc,C,m,pc+1)#tl frs)) )}"
| "exec_instr Pop P t h stk loc C⇩0 M⇩0 pc frs =
{(ε, (None, h, (tl stk, loc, C⇩0, M⇩0, pc+1)#frs) )}"
| "exec_instr Dup P t h stk loc C⇩0 M⇩0 pc frs =
{(ε, (None, h, (hd stk # stk, loc, C⇩0, M⇩0, pc+1)#frs) )}"
| "exec_instr Swap P t h stk loc C⇩0 M⇩0 pc frs =
{(ε, (None, h, (hd (tl stk) # hd stk # tl (tl stk), loc, C⇩0, M⇩0, pc+1)#frs) )}"
| "exec_instr (BinOpInstr bop) P t h stk loc C0 M0 pc frs =
{(ε,
case the (binop bop (hd (tl stk)) (hd stk)) of
Inl v ⇒ (None, h, (v # tl (tl stk), loc, C0, M0, pc+1) # frs)
| Inr a ⇒ (Some a, h, (stk, loc, C0, M0, pc) # frs))}"
| "exec_instr (IfFalse i) P t h stk loc C⇩0 M⇩0 pc frs =
{(ε, (let pc' = if hd stk = Bool False then nat(int pc+i) else pc+1
in (None, h, (tl stk, loc, C⇩0, M⇩0, pc')#frs)) )}"
| exec_instr_Goto:
"exec_instr (Goto i) P t h stk loc C⇩0 M⇩0 pc frs =
{(ε, (None, h, (stk, loc, C⇩0, M⇩0, nat(int pc+i))#frs) )}"
| "exec_instr ThrowExc P t h stk loc C⇩0 M⇩0 pc frs =
{(ε, (let xp' = if hd stk = Null then ⌊addr_of_sys_xcpt NullPointer⌋ else ⌊the_Addr(hd stk)⌋
in (xp', h, (stk, loc, C⇩0, M⇩0, pc)#frs)) )}"
| exec_instr_MEnter:
"exec_instr MEnter P t h stk loc C⇩0 M⇩0 pc frs =
{let v = hd stk
in if v = Null
then (ε, ⌊addr_of_sys_xcpt NullPointer⌋, h, (stk, loc, C⇩0, M⇩0, pc) # frs)
else (⦃Lock→the_Addr v, SyncLock (the_Addr v)⦄, None, h, (tl stk, loc, C⇩0, M⇩0, pc + 1) # frs)}"
| exec_instr_MExit:
"exec_instr MExit P t h stk loc C⇩0 M⇩0 pc frs =
(let v = hd stk
in if v = Null
then {(ε, ⌊addr_of_sys_xcpt NullPointer⌋, h, (stk, loc, C⇩0, M⇩0, pc)#frs)}
else {(⦃Unlock→the_Addr v, SyncUnlock (the_Addr v)⦄, None, h, (tl stk, loc, C⇩0, M⇩0, pc + 1) # frs),
(⦃UnlockFail→the_Addr v⦄, ⌊addr_of_sys_xcpt IllegalMonitorState⌋, h, (stk, loc, C⇩0, M⇩0, pc) # frs)})"
end
end
Theory JVMExceptions
section ‹Exception handling in the JVM›
theory JVMExceptions
imports
JVMInstructions
begin
abbreviation Any :: "cname option"
where "Any ≡ None"
definition matches_ex_entry :: "'m prog ⇒ cname ⇒ pc ⇒ ex_entry ⇒ bool"
where
"matches_ex_entry P C pc xcp ≡
let (s, e, C', h, d) = xcp in
s ≤ pc ∧ pc < e ∧ (case C' of None ⇒ True | ⌊C''⌋ ⇒ P ⊢ C ≼⇧* C'')"
primrec
match_ex_table :: "'m prog ⇒ cname ⇒ pc ⇒ ex_table ⇒ (pc × nat) option"
where
"match_ex_table P C pc [] = None"
| "match_ex_table P C pc (e#es) = (if matches_ex_entry P C pc e
then Some (snd(snd(snd e)))
else match_ex_table P C pc es)"
abbreviation ex_table_of :: "'addr jvm_prog ⇒ cname ⇒ mname ⇒ ex_table"
where "ex_table_of P C M == snd (snd (snd (the (snd (snd (snd(method P C M)))))))"
lemma match_ex_table_SomeD:
"match_ex_table P C pc xt = Some (pc',d') ⟹
∃(f,t,D,h,d) ∈ set xt. matches_ex_entry P C pc (f,t,D,h,d) ∧ h = pc' ∧ d=d'"
by (induct xt) (auto split: if_split_asm)
end
Theory JVMExec
section ‹Program Execution in the JVM›
theory JVMExec
imports
JVMExecInstr
JVMExceptions
"../Common/StartConfig"
begin
abbreviation instrs_of :: "'addr jvm_prog ⇒ cname ⇒ mname ⇒ 'addr instr list"
where "instrs_of P C M == fst(snd(snd(the(snd(snd(snd(method P C M)))))))"
subsection "single step execution"
context JVM_heap_base begin
fun exception_step :: "'addr jvm_prog ⇒ 'addr ⇒ 'heap ⇒ 'addr frame ⇒ 'addr frame list ⇒ ('addr, 'heap) jvm_state"
where
"exception_step P a h (stk, loc, C, M, pc) frs =
(case match_ex_table P (cname_of h a) pc (ex_table_of P C M) of
None ⇒ (⌊a⌋, h, frs)
| Some (pc', d) ⇒ (None, h, (Addr a # drop (size stk - d) stk, loc, C, M, pc') # frs))"
lemma exception_step_def_raw:
"exception_step =
(λP a h (stk, loc, C, M, pc) frs.
case match_ex_table P (cname_of h a) pc (ex_table_of P C M) of
None ⇒ (⌊a⌋, h, frs)
| Some (pc', d) ⇒ (None, h, (Addr a # drop (size stk - d) stk, loc, C, M, pc') # frs))"
by(intro ext) auto
fun exec :: "'addr jvm_prog ⇒ 'thread_id ⇒ ('addr, 'heap) jvm_state ⇒ ('addr, 'thread_id, 'heap) jvm_ta_state set" where
"exec P t (xcp, h, []) = {}"
| "exec P t (None, h, (stk, loc, C, M, pc) # frs) = exec_instr (instrs_of P C M ! pc) P t h stk loc C M pc frs"
| "exec P t (⌊a⌋, h, fr # frs) = {(ε, exception_step P a h fr frs)}"
subsection "relational view"
inductive exec_1 ::
"'addr jvm_prog ⇒ 'thread_id ⇒ ('addr, 'heap) jvm_state
⇒ ('addr, 'thread_id, 'heap) jvm_thread_action ⇒ ('addr, 'heap) jvm_state ⇒ bool"
("_,_ ⊢/ _ -_-jvm→/ _" [61,0,61,0,61] 60)
for P :: "'addr jvm_prog" and t :: 'thread_id
where
exec_1I:
"(ta, σ') ∈ exec P t σ ⟹ P,t ⊢ σ -ta-jvm→ σ'"
lemma exec_1_iff:
"P,t ⊢ σ -ta-jvm→ σ' ⟷ (ta, σ') ∈ exec P t σ"
by(auto intro: exec_1I elim: exec_1.cases)
end
text ‹
The start configuration of the JVM: in the start heap, we call a
method ‹m› of class ‹C› in program ‹P› with parameters @{term "vs"}. The
‹this› pointer of the frame is set to ‹Null› to simulate
a static method invokation.
›
abbreviation JVM_local_start ::
"cname ⇒ mname ⇒ ty list ⇒ ty ⇒ 'addr jvm_method ⇒ 'addr val list
⇒ 'addr jvm_thread_state"
where
"JVM_local_start ≡
λC M Ts T (mxs, mxl0, b) vs.
(None, [([], Null # vs @ replicate mxl0 undefined_value, C, M, 0)])"
context JVM_heap_base begin
abbreviation JVM_start_state ::
"'addr jvm_prog ⇒ cname ⇒ mname ⇒ 'addr val list ⇒ ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state"
where
"JVM_start_state ≡ start_state JVM_local_start"
definition JVM_start_state' :: "'addr jvm_prog ⇒ cname ⇒ mname ⇒ 'addr val list ⇒ ('addr, 'heap) jvm_state"
where
"JVM_start_state' P C M vs ≡
let (D, Ts, T, meth) = method P C M;
(mxs, mxl0, ins, xt) = the meth
in (None, start_heap, [([], Null # vs @ replicate mxl0 undefined_value, D, M, 0)])"
end
end
Theory JVMDefensive
section ‹A Defensive JVM›
theory JVMDefensive
imports JVMExec "../Common/ExternalCallWF"
begin
text ‹
Extend the state space by one element indicating a type error (or
other abnormal termination)›
datatype 'a type_error = TypeError | Normal 'a
context JVM_heap_base begin
definition is_Array_ref :: "'addr val ⇒ 'heap ⇒ bool" where
"is_Array_ref v h ≡
is_Ref v ∧
(v ≠ Null ⟶ typeof_addr h (the_Addr v) ≠ None ∧ is_Array (ty_of_htype (the (typeof_addr h (the_Addr v)))))"
declare is_Array_ref_def[simp]
primrec check_instr :: "['addr instr, 'addr jvm_prog, 'heap, 'addr val list, 'addr val list,
cname, mname, pc, 'addr frame list] ⇒ bool"
where
check_instr_Load:
"check_instr (Load n) P h stk loc C M⇩0 pc frs =
(n < length loc)"
| check_instr_Store:
"check_instr (Store n) P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk ∧ n < length loc)"
| check_instr_Push:
"check_instr (Push v) P h stk loc C⇩0 M⇩0 pc frs =
(¬is_Addr v)"
| check_instr_New:
"check_instr (New C) P h stk loc C⇩0 M⇩0 pc frs =
is_class P C"
| check_instr_NewArray:
"check_instr (NewArray T) P h stk loc C0 M0 pc frs =
(is_type P (T⌊⌉) ∧ 0 < length stk ∧ is_Intg (hd stk))"
| check_instr_ALoad:
"check_instr ALoad P h stk loc C0 M0 pc frs =
(1 < length stk ∧ is_Intg (hd stk) ∧ is_Array_ref (hd (tl stk)) h)"
| check_instr_AStore:
"check_instr AStore P h stk loc C0 M0 pc frs =
(2 < length stk ∧ is_Intg (hd (tl stk)) ∧ is_Array_ref (hd (tl (tl stk))) h ∧ typeof⇘h⇙ (hd stk) ≠ None)"
| check_instr_ALength:
"check_instr ALength P h stk loc C0 M0 pc frs =
(0 < length stk ∧ is_Array_ref (hd stk) h)"
| check_instr_Getfield:
"check_instr (Getfield F C) P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk ∧ (∃C' T fm. P ⊢ C sees F:T (fm) in C') ∧
(let (C', T, fm) = field P C F; ref = hd stk in
C' = C ∧ is_Ref ref ∧ (ref ≠ Null ⟶
(∃T. typeof_addr h (the_Addr ref) = ⌊T⌋ ∧ P ⊢ class_type_of T ≼⇧* C))))"
| check_instr_Putfield:
"check_instr (Putfield F C) P h stk loc C⇩0 M⇩0 pc frs =
(1 < length stk ∧ (∃C' T fm. P ⊢ C sees F:T (fm) in C') ∧
(let (C', T, fm) = field P C F; v = hd stk; ref = hd (tl stk) in
C' = C ∧ is_Ref ref ∧ (ref ≠ Null ⟶
(∃T'. typeof_addr h (the_Addr ref) = ⌊T'⌋ ∧ P ⊢ class_type_of T' ≼⇧* C ∧ P,h ⊢ v :≤ T))))"
| check_instr_CAS:
"check_instr (CAS F C) P h stk loc C0 M0 pc frs =
(2 < length stk ∧ (∃C' T fm. P ⊢ C sees F:T (fm) in C') ∧
(let (C', T, fm) = field P C F; v'' = hd stk; v' = hd (tl stk); v = hd (tl (tl stk)) in
C' = C ∧ is_Ref v ∧ volatile fm ∧ (v ≠ Null ⟶
(∃T'. typeof_addr h (the_Addr v) = ⌊T'⌋ ∧ P ⊢ class_type_of T' ≼⇧* C ∧ P,h ⊢ v' :≤ T ∧ P,h ⊢ v'' :≤ T))))"
| check_instr_Checkcast:
"check_instr (Checkcast T) P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk ∧ is_type P T)"
| check_instr_Instanceof:
"check_instr (Instanceof T) P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk ∧ is_type P T ∧ is_Ref (hd stk))"
| check_instr_Invoke:
"check_instr (Invoke M n) P h stk loc C⇩0 M⇩0 pc frs =
(n < length stk ∧ is_Ref (stk!n) ∧
(stk!n ≠ Null ⟶
(let a = the_Addr (stk!n);
T = the (typeof_addr h a);
C = class_type_of T;
(D, Ts, Tr, meth) = method P C M
in typeof_addr h a ≠ None ∧ P ⊢ C has M ∧
P,h ⊢ rev (take n stk) [:≤] Ts ∧
(meth = None ⟶ D∙M(Ts) :: Tr))))"
| check_instr_Return:
"check_instr Return P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk ∧ ((0 < length frs) ⟶
(P ⊢ C⇩0 has M⇩0) ∧
(let v = hd stk;
T = fst (snd (snd (method P C⇩0 M⇩0)))
in P,h ⊢ v :≤ T)))"
| check_instr_Pop:
"check_instr Pop P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk)"
| check_instr_Dup:
"check_instr Dup P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk)"
| check_instr_Swap:
"check_instr Swap P h stk loc C⇩0 M⇩0 pc frs =
(1 < length stk)"
| check_instr_BinOpInstr:
"check_instr (BinOpInstr bop) P h stk loc C0 M0 pc frs =
(1 < length stk ∧ (∃T1 T2 T. typeof⇘h⇙ (hd stk) = ⌊T2⌋ ∧ typeof⇘h⇙ (hd (tl stk)) = ⌊T1⌋ ∧ P ⊢ T1«bop»T2 : T))"
| check_instr_IfFalse:
"check_instr (IfFalse b) P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk ∧ is_Bool (hd stk) ∧ 0 ≤ int pc+b)"
| check_instr_Goto:
"check_instr (Goto b) P h stk loc C⇩0 M⇩0 pc frs =
(0 ≤ int pc+b)"
| check_instr_Throw:
"check_instr ThrowExc P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk ∧ is_Ref (hd stk) ∧ P ⊢ the (typeof⇘h⇙ (hd stk)) ≤ Class Throwable)"
| check_instr_MEnter:
"check_instr MEnter P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk ∧ is_Ref (hd stk))"
| check_instr_MExit:
"check_instr MExit P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk ∧ is_Ref (hd stk))"
definition check_xcpt :: "'addr jvm_prog ⇒ 'heap ⇒ nat ⇒ pc ⇒ ex_table ⇒ 'addr ⇒ bool"
where
"check_xcpt P h n pc xt a ⟷
(∃C. typeof_addr h a = ⌊Class_type C⌋ ∧
(case match_ex_table P C pc xt of None ⇒ True | Some (pc', d') ⇒ d' ≤ n))"
definition check :: "'addr jvm_prog ⇒ ('addr, 'heap) jvm_state ⇒ bool"
where
"check P σ ≡ let (xcpt, h, frs) = σ in
(case frs of [] ⇒ True | (stk,loc,C,M,pc)#frs' ⇒
P ⊢ C has M ∧
(let (C',Ts,T,meth) = method P C M; (mxs,mxl⇩0,ins,xt) = the meth; i = ins!pc in
meth ≠ None ∧ pc < size ins ∧ size stk ≤ mxs ∧
(case xcpt of None ⇒ check_instr i P h stk loc C M pc frs'
| Some a ⇒ check_xcpt P h (length stk) pc xt a)))"
definition exec_d ::
"'addr jvm_prog ⇒ 'thread_id ⇒ ('addr, 'heap) jvm_state ⇒ ('addr, 'thread_id, 'heap) jvm_ta_state set type_error"
where
"exec_d P t σ ≡ if check P σ then Normal (exec P t σ) else TypeError"
inductive
exec_1_d ::
"'addr jvm_prog ⇒ 'thread_id ⇒ ('addr, 'heap) jvm_state type_error
⇒ ('addr, 'thread_id, 'heap) jvm_thread_action ⇒ ('addr, 'heap) jvm_state type_error ⇒ bool"
("_,_ ⊢ _ -_-jvmd→ _" [61,0,61,0,61] 60)
for P :: "'addr jvm_prog" and t :: 'thread_id
where
exec_1_d_ErrorI: "exec_d P t σ = TypeError ⟹ P,t ⊢ Normal σ -ε-jvmd→ TypeError"
| exec_1_d_NormalI: "⟦ exec_d P t σ = Normal Σ; (tas, σ') ∈ Σ ⟧ ⟹ P,t ⊢ Normal σ -tas-jvmd→ Normal σ'"
lemma jvmd_NormalD:
"P,t ⊢ Normal σ -ta-jvmd→ Normal σ' ⟹ check P σ ∧ (ta, σ') ∈ exec P t σ ∧ (∃xcp h f frs. σ = (xcp, h, f # frs))"
apply(erule exec_1_d.cases, auto simp add: exec_d_def split: if_split_asm)
apply(case_tac b, auto)
done
lemma jvmd_NormalE:
assumes "P,t ⊢ Normal σ -ta-jvmd→ Normal σ'"
obtains xcp h f frs where "check P σ" "(ta, σ') ∈ exec P t σ" "σ = (xcp, h, f # frs)"
using assms
by(auto dest: jvmd_NormalD)
lemma exec_d_eq_TypeError: "exec_d P t σ = TypeError ⟷ ¬ check P σ"
by(simp add: exec_d_def)
lemma exec_d_eq_Normal: "exec_d P t σ = Normal (exec P t σ) ⟷ check P σ"
by(auto simp add: exec_d_def)
end
declare split_paired_All [simp del]
declare split_paired_Ex [simp del]
lemma if_neq [dest!]:
"(if P then A else B) ≠ B ⟹ P"
by (cases P, auto)
context JVM_heap_base begin
lemma exec_d_no_errorI [intro]:
"check P σ ⟹ exec_d P t σ ≠ TypeError"
by (unfold exec_d_def) simp
theorem no_type_error_commutes:
"exec_d P t σ ≠ TypeError ⟹ exec_d P t σ = Normal (exec P t σ)"
by (unfold exec_d_def, auto)
lemma defensive_imp_aggressive_1:
"P,t ⊢ (Normal σ) -tas-jvmd→ (Normal σ') ⟹ P,t ⊢ σ -tas-jvm→ σ'"
by(auto elim!: exec_1_d.cases intro!: exec_1.intros simp add: exec_d_def split: if_split_asm)
end
context JVM_heap begin
lemma check_exec_hext:
assumes exec: "(ta, xcp', h', frs') ∈ exec P t (xcp, h, frs)"
and check: "check P (xcp, h, frs)"
shows "h ⊴ h'"
proof -
from exec have "frs ≠ []" by(auto)
then obtain f Frs where frs [simp]: "frs = f # Frs"
by(fastforce simp add: neq_Nil_conv)
obtain stk loc C0 M0 pc where f [simp]: "f = (stk, loc, C0, M0, pc)"
by(cases f, blast)
show ?thesis
proof(cases xcp)
case None
with check obtain C' Ts T mxs mxl0 ins xt
where mthd: "P ⊢ C0 sees M0 : Ts → T = ⌊(mxs, mxl0, ins, xt)⌋ in C'"
"method P C0 M0 = (C', Ts, T, ⌊(mxs, mxl0, ins, xt)⌋)"
and check_ins: "check_instr (ins ! pc) P h stk loc C0 M0 pc Frs"
and "pc < length ins"
and "length stk ≤ mxs"
by(auto simp add: check_def has_method_def)
from None exec mthd
have xexec: "(ta, xcp', h', frs') ∈ exec_instr (ins ! pc) P t h stk loc C0 M0 pc Frs" by(clarsimp)
thus ?thesis
proof(cases "ins ! pc")
case (New C)
with xexec show ?thesis
by(auto intro: hext_allocate split: if_split_asm)
next
case (NewArray T)
with xexec show ?thesis
by(auto intro: hext_allocate split: if_split_asm)
next
case AStore
with xexec check_ins show ?thesis
by(auto simp add: split_beta split: if_split_asm intro: hext_heap_write)
next
case Putfield
with xexec check_ins show ?thesis
by(auto intro: hext_heap_write simp add: split_beta split: if_split_asm)
next
case CAS
with xexec check_ins show ?thesis
by(auto intro: hext_heap_write simp add: split_beta split: if_split_asm)
next
case (Invoke M n)
with xexec check_ins show ?thesis
apply(auto simp add: min_def split_beta is_Ref_def extRet2JVM_def has_method_def
split: if_split_asm intro: red_external_aggr_hext)
apply(case_tac va)
apply(auto 4 3 intro: red_external_aggr_hext is_native.intros)
done
next
case (BinOpInstr bop)
with xexec check_ins show ?thesis by(auto split: sum.split_asm)
qed(auto simp add: split_beta split: if_split_asm)
next
case (Some a)
with exec have "h' = h" by auto
thus ?thesis by auto
qed
qed
lemma exec_1_d_hext:
"⟦ P,t ⊢ Normal (xcp, h, frs) -ta-jvmd→ Normal (xcp', h', frs') ⟧ ⟹ h ⊴ h'"
by(auto elim!: exec_1_d.cases simp add: exec_d_def split: if_split_asm intro: check_exec_hext)
end
end
Theory JVMThreaded
section ‹Instantiating the framework semantics with the JVM›
theory JVMThreaded
imports
JVMDefensive
"../Common/ConformThreaded"
"../Framework/FWLiftingSem"
"../Framework/FWProgressAux"
begin
primrec JVM_final :: "'addr jvm_thread_state ⇒ bool"
where
"JVM_final (xcp, frs) = (frs = [])"
text‹The aggressive JVM›
context JVM_heap_base begin
abbreviation mexec ::
"'addr jvm_prog ⇒ 'thread_id ⇒ ('addr jvm_thread_state × 'heap)
⇒ ('addr, 'thread_id, 'heap) jvm_thread_action ⇒ ('addr jvm_thread_state × 'heap) ⇒ bool"
where
"mexec P t ≡ (λ((xcp, frstls), h) ta ((xcp', frstls'), h'). P,t ⊢ (xcp, h, frstls) -ta-jvm→ (xcp', h', frstls'))"
lemma NewThread_memory_exec_instr:
"⟦ (ta, s) ∈ exec_instr I P t h stk loc C M pc frs; NewThread t' x m ∈ set ⦃ta⦄⇘t⇙ ⟧ ⟹ m = fst (snd s)"
apply(cases I)
apply(auto split: if_split_asm simp add: split_beta ta_upd_simps)
apply(auto dest!: red_ext_aggr_new_thread_heap simp add: extRet2JVM_def split: extCallRet.split)
done
lemma NewThread_memory_exec:
"⟦ P,t ⊢ σ -ta-jvm→ σ'; NewThread t' x m ∈ set ⦃ta⦄⇘t⇙ ⟧ ⟹ m = (fst (snd σ'))"
apply(erule exec_1.cases)
apply(clarsimp)
apply(case_tac bb, simp)
apply(case_tac ag, auto simp add: exception_step_def_raw split: list.split_asm)
apply(drule NewThread_memory_exec_instr, simp+)
done
lemma exec_instr_Wakeup_no_Lock_no_Join_no_Interrupt:
"⟦ (ta, s) ∈ exec_instr I P t h stk loc C M pc frs; Notified ∈ set ⦃ta⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta⦄⇘w⇙ ⟧
⟹ collect_locks ⦃ta⦄⇘l⇙ = {} ∧ collect_cond_actions ⦃ta⦄⇘c⇙ = {} ∧ collect_interrupts ⦃ta⦄⇘i⇙ = {}"
apply(cases I)
apply(auto split: if_split_asm simp add: split_beta ta_upd_simps dest: red_external_aggr_Wakeup_no_Join)
done
lemma mexec_instr_Wakeup_no_Join:
"⟦ P,t ⊢ σ -ta-jvm→ σ'; Notified ∈ set ⦃ta⦄⇘w⇙ ∨ WokenUp ∈ set ⦃ta⦄⇘w⇙ ⟧
⟹ collect_locks ⦃ta⦄⇘l⇙ = {} ∧ collect_cond_actions ⦃ta⦄⇘c⇙ = {} ∧ collect_interrupts ⦃ta⦄⇘i⇙ = {}"
apply(erule exec_1.cases)
apply(clarsimp)
apply(case_tac bb, simp)
apply(case_tac ag, clarsimp simp add: exception_step_def_raw split: list.split_asm del: disjE)
apply(drule exec_instr_Wakeup_no_Lock_no_Join_no_Interrupt)
apply auto
done
lemma mexec_final:
"⟦ mexec P t (x, m) ta (x', m'); JVM_final x ⟧ ⟹ False"
by(cases x)(auto simp add: exec_1_iff)
lemma exec_mthr: "multithreaded JVM_final (mexec P)"
apply(unfold_locales)
apply(clarsimp, drule NewThread_memory_exec, fastforce, simp)
apply(erule (1) mexec_final)
done
end
sublocale JVM_heap_base < exec_mthr:
multithreaded
JVM_final
"mexec P"
convert_RA
for P
by(rule exec_mthr)
context JVM_heap_base begin
abbreviation mexecT ::
"'addr jvm_prog
⇒ ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state
⇒ 'thread_id × ('addr, 'thread_id, 'heap) jvm_thread_action
⇒ ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state ⇒ bool"
where
"mexecT P ≡ exec_mthr.redT P"
abbreviation mexecT_syntax1 ::
"'addr jvm_prog ⇒ ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state
⇒ 'thread_id ⇒ ('addr, 'thread_id, 'heap) jvm_thread_action
⇒ ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state ⇒ bool"
("_ ⊢ _ -_▹_→⇘jvm⇙ _" [50,0,0,0,50] 80)
where
"mexecT_syntax1 P s t ta s' ≡ mexecT P s (t, ta) s'"
abbreviation mExecT_syntax1 ::
"'addr jvm_prog ⇒ ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state
⇒ ('thread_id × ('addr, 'thread_id, 'heap) jvm_thread_action) list
⇒ ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state ⇒ bool"
("_ ⊢ _ -▹_→⇘jvm⇙* _" [50,0,0,50] 80)
where
"P ⊢ s -▹ttas→⇘jvm⇙* s' ≡ exec_mthr.RedT P s ttas s'"
text‹The defensive JVM›
abbreviation mexecd ::
"'addr jvm_prog ⇒ 'thread_id ⇒ 'addr jvm_thread_state × 'heap
⇒ ('addr, 'thread_id, 'heap) jvm_thread_action ⇒ 'addr jvm_thread_state × 'heap ⇒ bool"
where
"mexecd P t ≡ (λ((xcp, frstls), h) ta ((xcp', frstls'), h'). P,t ⊢ Normal (xcp, h, frstls) -ta-jvmd→ Normal (xcp', h', frstls'))"
lemma execd_mthr: "multithreaded JVM_final (mexecd P)"
apply(unfold_locales)
apply(fastforce dest: defensive_imp_aggressive_1 NewThread_memory_exec)
apply(auto elim: jvmd_NormalE)
done
end
sublocale JVM_heap_base < execd_mthr:
multithreaded
JVM_final
"mexecd P"
convert_RA
for P
by(rule execd_mthr)
context JVM_heap_base begin
abbreviation mexecdT ::
"'addr jvm_prog ⇒ ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state
⇒ 'thread_id × ('addr, 'thread_id, 'heap) jvm_thread_action
⇒ ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state ⇒ bool"
where
"mexecdT P ≡ execd_mthr.redT P"
abbreviation mexecdT_syntax1 ::
"'addr jvm_prog ⇒ ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state
⇒ 'thread_id ⇒ ('addr, 'thread_id, 'heap) jvm_thread_action
⇒ ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state ⇒ bool"
("_ ⊢ _ -_▹_→⇘jvmd⇙ _" [50,0,0,0,50] 80)
where
"mexecdT_syntax1 P s t ta s' ≡ mexecdT P s (t, ta) s'"
abbreviation mExecdT_syntax1 ::
"'addr jvm_prog ⇒ ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state
⇒ ('thread_id × ('addr, 'thread_id, 'heap) jvm_thread_action) list
⇒ ('addr,'thread_id,'addr jvm_thread_state,'heap,'addr) state ⇒ bool"
("_ ⊢ _ -▹_→⇘jvmd⇙* _" [50,0,0,50] 80)
where
"P ⊢ s -▹ttas→⇘jvmd⇙* s' ≡ execd_mthr.RedT P s ttas s'"
lemma mexecd_Suspend_Invoke:
"⟦ mexecd P t (x, m) ta (x', m'); Suspend w ∈ set ⦃ta⦄⇘w⇙ ⟧
⟹ ∃stk loc C M pc frs' n a T Ts Tr D. x' = (None, (stk, loc, C, M, pc) # frs') ∧ instrs_of P C M ! pc = Invoke wait n ∧ stk ! n = Addr a ∧ typeof_addr m a = ⌊T⌋ ∧ P ⊢ class_type_of T sees wait:Ts→Tr = Native in D ∧ D∙wait(Ts) :: Tr"
apply(cases x')
apply(cases x)
apply(cases "fst x")
apply(auto elim!: jvmd_NormalE simp add: split_beta)
apply(rename_tac [!] stk loc C M pc frs)
apply(case_tac [!] "instrs_of P C M ! pc")
apply(auto split: if_split_asm simp add: split_beta check_def is_Ref_def has_method_def)
apply(frule red_external_aggr_Suspend_StaySame, simp, drule red_external_aggr_Suspend_waitD, simp, fastforce)+
done
end
context JVM_heap begin
lemma exec_instr_New_Thread_exists_thread_object:
"⟦ (ta, xcp', h', frs') ∈ exec_instr ins P t h stk loc C M pc frs;
check_instr ins P h stk loc C M pc frs;
NewThread t' x h'' ∈ set ⦃ta⦄⇘t⇙ ⟧
⟹ ∃C. typeof_addr h' (thread_id2addr t') = ⌊Class_type C⌋ ∧ P ⊢ C ≼⇧* Thread"
apply(cases ins)
apply(fastforce simp add: split_beta ta_upd_simps split: if_split_asm intro: red_external_aggr_new_thread_exists_thread_object)+
done
lemma exec_New_Thread_exists_thread_object:
"⟦ P,t ⊢ Normal (xcp, h, frs) -ta-jvmd→ Normal (xcp', h', frs'); NewThread t' x h'' ∈ set ⦃ta⦄⇘t⇙ ⟧
⟹ ∃C. typeof_addr h' (thread_id2addr t') = ⌊Class_type C⌋ ∧ P ⊢ C ≼⇧* Thread"
apply(cases xcp)
apply(case_tac [!] frs)
apply(auto simp add: check_def elim!: jvmd_NormalE dest!: exec_instr_New_Thread_exists_thread_object)
done
lemma exec_instr_preserve_tconf:
"⟦ (ta, xcp', h', frs') ∈ exec_instr ins P t h stk loc C M pc frs;
check_instr ins P h stk loc C M pc frs;
P,h ⊢ t' √t ⟧
⟹ P,h' ⊢ t' √t"
apply(cases ins)
apply(auto intro: tconf_hext_mono hext_allocate hext_heap_write red_external_aggr_preserves_tconf split: if_split_asm sum.split_asm simp add: split_beta has_method_def intro!: is_native.intros cong del: image_cong_simp)
done
lemma exec_preserve_tconf:
"⟦ P,t ⊢ Normal (xcp, h, frs) -ta-jvmd→ Normal (xcp', h', frs'); P,h ⊢ t' √t ⟧ ⟹ P,h' ⊢ t' √t"
apply(cases xcp)
apply(case_tac [!] frs)
apply(auto simp add: check_def elim!: jvmd_NormalE elim!: exec_instr_preserve_tconf)
done
lemma lifting_wf_thread_conf: "lifting_wf JVM_final (mexecd P) (λt x m. P,m ⊢ t √t)"
by(unfold_locales)(auto intro: exec_preserve_tconf dest: exec_New_Thread_exists_thread_object intro: tconfI)
end
sublocale JVM_heap < execd_tconf: lifting_wf JVM_final "mexecd P" convert_RA "λt x m. P,m ⊢ t √t"
by(rule lifting_wf_thread_conf)
context JVM_heap begin
lemma execd_hext:
"P ⊢ s -t▹ta→⇘jvmd⇙ s' ⟹ shr s ⊴ shr s'"
by(auto elim!: execd_mthr.redT.cases dest!: exec_1_d_hext intro: hext_trans)
lemma Execd_hext:
assumes "P ⊢ s -▹tta→⇘jvmd⇙* s'"
shows "shr s ⊴ shr s'"
using assms unfolding execd_mthr.RedT_def
by(induct)(auto dest!: execd_hext intro: hext_trans simp add: execd_mthr.RedT_def)
end
end
Theory JVM_Main
theory JVM_Main
imports
JVMState
JVMThreaded
begin
end
Theory JVM_SemiType
chapter ‹Bytecode verifier›
section ‹The JVM Type System as Semilattice›
theory JVM_SemiType
imports
"../Common/SemiType"
begin
type_synonym ty⇩l = "ty err list"
type_synonym ty⇩s = "ty list"
type_synonym ty⇩i = "ty⇩s × ty⇩l"
type_synonym ty⇩i' = "ty⇩i option"
type_synonym ty⇩m = "ty⇩i' list"
type_synonym ty⇩P = "mname ⇒ cname ⇒ ty⇩m"
definition stk_esl :: "'c prog ⇒ nat ⇒ ty⇩s esl"
where
"stk_esl P mxs ≡ upto_esl mxs (SemiType.esl P)"
definition loc_sl :: "'c prog ⇒ nat ⇒ ty⇩l sl"
where
"loc_sl P mxl ≡ Listn.sl mxl (Err.sl (SemiType.esl P))"
definition sl :: "'c prog ⇒ nat ⇒ nat ⇒ ty⇩i' err sl"
where
"sl P mxs mxl ≡
Err.sl(Opt.esl(Product.esl (stk_esl P mxs) (Err.esl(loc_sl P mxl))))"
definition "states" :: "'c prog ⇒ nat ⇒ nat ⇒ ty⇩i' err set"
where
"states P mxs mxl ≡ fst(sl P mxs mxl)"
definition le :: "'c prog ⇒ nat ⇒ nat ⇒ ty⇩i' err ord"
where
"le P mxs mxl ≡ fst(snd(sl P mxs mxl))"
definition sup :: "'c prog ⇒ nat ⇒ nat ⇒ ty⇩i' err binop"
where
"sup P mxs mxl ≡ snd(snd(sl P mxs mxl))"
definition sup_ty_opt :: "['c prog,ty err,ty err] ⇒ bool"
("_ ⊢ _ ≤⇩⊤ _" [71,71,71] 70)
where
"sup_ty_opt P ≡ Err.le (widen P)"
definition sup_state :: "['c prog,ty⇩i,ty⇩i] ⇒ bool"
("_ ⊢ _ ≤⇩i _" [71,71,71] 70)
where
"sup_state P ≡ Product.le (Listn.le (widen P)) (Listn.le (sup_ty_opt P))"
definition sup_state_opt :: "['c prog,ty⇩i',ty⇩i'] ⇒ bool"
("_ ⊢ _ ≤'' _" [71,71,71] 70)
where
"sup_state_opt P ≡ Opt.le (sup_state P)"
abbreviation sup_loc :: "['c prog,ty⇩l,ty⇩l] ⇒ bool" ("_ ⊢ _ [≤⇩⊤] _" [71,71,71] 70)
where "P ⊢ LT [≤⇩⊤] LT' ≡ list_all2 (sup_ty_opt P) LT LT'"
notation (ASCII)
sup_ty_opt ("_ |- _ <=T _" [71,71,71] 70) and
sup_state ("_ |- _ <=i _" [71,71,71] 70) and
sup_state_opt ("_ |- _ <=' _" [71,71,71] 70) and
sup_loc ("_ |- _ [<=T] _" [71,71,71] 70)
subsection "Unfolding"
lemma JVM_states_unfold:
"states P mxs mxl ≡ err(opt((Union {list n (types P) |n. n <= mxs}) ×
list mxl (err(types P))))"
apply (unfold states_def sl_def Opt.esl_def Err.sl_def
stk_esl_def loc_sl_def Product.esl_def
Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
apply simp
done
lemma JVM_le_unfold:
"le P m n ≡
Err.le(Opt.le(Product.le(Listn.le(widen P))(Listn.le(Err.le(widen P)))))"
apply (unfold le_def sl_def Opt.esl_def Err.sl_def
stk_esl_def loc_sl_def Product.esl_def
Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
apply simp
done
lemma sl_def2:
"JVM_SemiType.sl P mxs mxl ≡
(states P mxs mxl, JVM_SemiType.le P mxs mxl, JVM_SemiType.sup P mxs mxl)"
by (unfold JVM_SemiType.sup_def states_def JVM_SemiType.le_def) simp
lemma JVM_le_conv:
"le P m n (OK t1) (OK t2) = P ⊢ t1 ≤' t2"
by (simp add: JVM_le_unfold Err.le_def lesub_def sup_state_opt_def
sup_state_def sup_ty_opt_def)
lemma JVM_le_Err_conv:
"le P m n = Err.le (sup_state_opt P)"
by (unfold sup_state_opt_def sup_state_def
sup_ty_opt_def JVM_le_unfold) simp
lemma err_le_unfold [iff]:
"Err.le r (OK a) (OK b) = r a b"
by (simp add: Err.le_def lesub_def)
subsection ‹Semilattice›
lemma order_sup_state_opt [intro, simp]:
"wf_prog wf_mb P ⟹ order (sup_state_opt P)"
by (unfold sup_state_opt_def sup_state_def sup_ty_opt_def) blast
lemma semilat_JVM [intro?]:
"wf_prog wf_mb P ⟹ semilat (JVM_SemiType.sl P mxs mxl)"
apply (unfold JVM_SemiType.sl_def stk_esl_def loc_sl_def)
apply (blast intro: err_semilat_Product_esl err_semilat_upto_esl
Listn_sl err_semilat_JType_esl)
done
lemma acc_JVM [intro]:
"wf_prog wf_mb P ⟹ acc (JVM_SemiType.states P mxs mxl) (JVM_SemiType.le P mxs mxl)"
by(unfold JVM_le_unfold JVM_states_unfold) blast
subsection ‹Widening with ‹⊤››
lemma widen_refl[iff]: "widen P t t" by (simp add: fun_of_def)
lemma sup_ty_opt_refl [iff]: "P ⊢ T ≤⇩⊤ T"
apply (unfold sup_ty_opt_def)
apply (fold lesub_def)
apply (rule le_err_refl)
apply (simp add: lesub_def)
done
lemma Err_any_conv [iff]: "P ⊢ Err ≤⇩⊤ T = (T = Err)"
by (unfold sup_ty_opt_def) (rule Err_le_conv [simplified lesub_def])
lemma any_Err [iff]: "P ⊢ T ≤⇩⊤ Err"
by (unfold sup_ty_opt_def) (rule le_Err [simplified lesub_def])
lemma OK_OK_conv [iff]:
"P ⊢ OK T ≤⇩⊤ OK T' = P ⊢ T ≤ T'"
by (simp add: sup_ty_opt_def fun_of_def)
lemma any_OK_conv [iff]:
"P ⊢ X ≤⇩⊤ OK T' = (∃T. X = OK T ∧ P ⊢ T ≤ T')"
apply (unfold sup_ty_opt_def)
apply (rule le_OK_conv [simplified lesub_def])
done
lemma OK_any_conv:
"P ⊢ OK T ≤⇩⊤ X = (X = Err ∨ (∃T'. X = OK T' ∧ P ⊢ T ≤ T'))"
apply (unfold sup_ty_opt_def)
apply (rule OK_le_conv [simplified lesub_def])
done
lemma sup_ty_opt_trans [intro?, trans]:
"⟦P ⊢ a ≤⇩⊤ b; P ⊢ b ≤⇩⊤ c⟧ ⟹ P ⊢ a ≤⇩⊤ c"
by (auto intro: widen_trans
simp add: sup_ty_opt_def Err.le_def lesub_def fun_of_def
split: err.splits)
subsection "Stack and Registers"
lemma stk_convert:
"P ⊢ ST [≤] ST' = Listn.le (widen P) ST ST'"
by (simp add: Listn.le_def lesub_def)
lemma sup_loc_refl [iff]: "P ⊢ LT [≤⇩⊤] LT"
by (rule list_all2_refl) simp
lemmas sup_loc_Cons1 [iff] = list_all2_Cons1 [of "sup_ty_opt P"] for P
lemma sup_loc_def:
"P ⊢ LT [≤⇩⊤] LT' ≡ Listn.le (sup_ty_opt P) LT LT'"
by (simp add: Listn.le_def lesub_def)
lemma sup_loc_widens_conv [iff]:
"P ⊢ map OK Ts [≤⇩⊤] map OK Ts' = P ⊢ Ts [≤] Ts'"
by (simp add: list_all2_map1 list_all2_map2)
lemma sup_loc_trans [intro?, trans]:
"⟦P ⊢ a [≤⇩⊤] b; P ⊢ b [≤⇩⊤] c⟧ ⟹ P ⊢ a [≤⇩⊤] c"
by (rule list_all2_trans, rule sup_ty_opt_trans)
subsection "State Type"
lemma sup_state_conv [iff]:
"P ⊢ (ST,LT) ≤⇩i (ST',LT') = (P ⊢ ST [≤] ST' ∧ P ⊢ LT [≤⇩⊤] LT')"
by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def sup_loc_def)
lemma sup_state_conv2:
"P ⊢ s1 ≤⇩i s2 = (P ⊢ fst s1 [≤] fst s2 ∧ P ⊢ snd s1 [≤⇩⊤] snd s2)"
by (cases s1, cases s2) simp
lemma sup_state_refl [iff]: "P ⊢ s ≤⇩i s"
by (auto simp add: sup_state_conv2 intro: list_all2_refl)
lemma sup_state_trans [intro?, trans]:
"⟦P ⊢ a ≤⇩i b; P ⊢ b ≤⇩i c⟧ ⟹ P ⊢ a ≤⇩i c"
by (auto intro: sup_loc_trans widens_trans simp add: sup_state_conv2)
lemma sup_state_opt_None_any [iff]:
"P ⊢ None ≤' s"
by (simp add: sup_state_opt_def Opt.le_def)
lemma sup_state_opt_any_None [iff]:
"P ⊢ s ≤' None = (s = None)"
by (simp add: sup_state_opt_def Opt.le_def)
lemma sup_state_opt_Some_Some [iff]:
"P ⊢ Some a ≤' Some b = P ⊢ a ≤⇩i b"
by (simp add: sup_state_opt_def Opt.le_def lesub_def)
lemma sup_state_opt_any_Some:
"P ⊢ (Some s) ≤' X = (∃s'. X = Some s' ∧ P ⊢ s ≤⇩i s')"
by (simp add: sup_state_opt_def Opt.le_def lesub_def)
lemma sup_state_opt_refl [iff]: "P ⊢ s ≤' s"
by (simp add: sup_state_opt_def Opt.le_def lesub_def)
lemma sup_state_opt_trans [intro?, trans]:
"⟦P ⊢ a ≤' b; P ⊢ b ≤' c⟧ ⟹ P ⊢ a ≤' c"
apply (unfold sup_state_opt_def Opt.le_def lesub_def)
apply (simp del: split_paired_All)
apply (rule sup_state_trans, assumption+)
done
end
Theory Effect
section ‹Effect of Instructions on the State Type›
theory Effect
imports
JVM_SemiType
"../JVM/JVMExceptions"
begin
locale jvm_method = prog +
fixes mxs :: nat
fixes mxl⇩0 :: nat
fixes Ts :: "ty list"
fixes T⇩r :: ty
fixes "is" :: "'addr instr list"
fixes xt :: ex_table
fixes mxl :: nat
defines mxl_def: "mxl ≡ 1+size Ts+mxl⇩0"
text ‹Program counter of successor instructions:›
primrec succs :: "'addr instr ⇒ ty⇩i ⇒ pc ⇒ pc list"
where
"succs (Load idx) τ pc = [pc+1]"
| "succs (Store idx) τ pc = [pc+1]"
| "succs (Push v) τ pc = [pc+1]"
| "succs (Getfield F C) τ pc = [pc+1]"
| "succs (Putfield F C) τ pc = [pc+1]"
| "succs (CAS F C) τ pc = [pc+1]"
| "succs (New C) τ pc = [pc+1]"
| "succs (NewArray T) τ pc = [pc+1]"
| "succs ALoad τ pc = (if (fst τ)!1 = NT then [] else [pc+1])"
| "succs AStore τ pc = (if (fst τ)!2 = NT then [] else [pc+1])"
| "succs ALength τ pc = (if (fst τ)!0 = NT then [] else [pc+1])"
| "succs (Checkcast C) τ pc = [pc+1]"
| "succs (Instanceof T) τ pc = [pc+1]"
| "succs Pop τ pc = [pc+1]"
| "succs Dup τ pc = [pc+1]"
| "succs Swap τ pc = [pc+1]"
| "succs (BinOpInstr b) τ pc = [pc+1]"
| succs_IfFalse:
"succs (IfFalse b) τ pc = [pc+1, nat (int pc + b)]"
| succs_Goto:
"succs (Goto b) τ pc = [nat (int pc + b)]"
| succs_Return:
"succs Return τ pc = []"
| succs_Invoke:
"succs (Invoke M n) τ pc = (if (fst τ)!n = NT then [] else [pc+1])"
| succs_Throw:
"succs ThrowExc τ pc = []"
| "succs MEnter τ pc = (if (fst τ)!0 = NT then [] else [pc+1])"
| "succs MExit τ pc = (if (fst τ)!0 = NT then [] else [pc+1])"
text "Effect of instruction on the state type:"
fun eff⇩i :: "'addr instr × 'm prog × ty⇩i ⇒ ty⇩i"
where
eff⇩i_Load:
"eff⇩i (Load n, P, (ST, LT)) = (ok_val (LT ! n) # ST, LT)"
| eff⇩i_Store:
"eff⇩i (Store n, P, (T#ST, LT)) = (ST, LT[n:= OK T])"
| eff⇩i_Push:
"eff⇩i (Push v, P, (ST, LT)) = (the (typeof v) # ST, LT)"
| eff⇩i_Getfield:
"eff⇩i (Getfield F C, P, (T#ST, LT)) = (fst (snd (field P C F)) # ST, LT)"
| eff⇩i_Putfield:
"eff⇩i (Putfield F C, P, (T⇩1#T⇩2#ST, LT)) = (ST,LT)"
| eff⇩i_CAS:
"eff⇩i (CAS F C, P, (T⇩1#T⇩2#T⇩3#ST, LT)) = (Boolean # ST, LT)"
| eff⇩i_New:
"eff⇩i (New C, P, (ST,LT)) = (Class C # ST, LT)"
| eff⇩i_NewArray:
"eff⇩i (NewArray Ty, P, (T#ST,LT)) = (Ty⌊⌉ # ST,LT)"
| eff⇩i_ALoad:
"eff⇩i (ALoad, P, (T1#T2#ST,LT)) = (the_Array T2# ST,LT)"
| eff⇩i_AStore:
"eff⇩i (AStore, P, (T1#T2#T3#ST,LT)) = (ST,LT)"
| eff⇩i_ALength:
"eff⇩i (ALength, P, (T1#ST,LT)) = (Integer#ST,LT)"
| eff⇩i_Checkcast:
"eff⇩i (Checkcast Ty, P, (T#ST,LT)) = (Ty # ST,LT)"
| eff⇩i_Instanceof:
"eff⇩i (Instanceof Ty, P, (T#ST,LT)) = (Boolean # ST,LT)"
| eff⇩i_Pop:
"eff⇩i (Pop, P, (T#ST,LT)) = (ST,LT)"
| eff⇩i_Dup:
"eff⇩i (Dup, P, (T#ST,LT)) = (T#T#ST,LT)"
| eff⇩i_Swap:
"eff⇩i (Swap, P, (T1#T2#ST,LT)) = (T2#T1#ST,LT)"
| eff⇩i_BinOpInstr:
"eff⇩i (BinOpInstr bop, P, (T2#T1#ST,LT)) = ((THE T. P ⊢ T1«bop»T2 : T)#ST, LT)"
| eff⇩i_IfFalse:
"eff⇩i (IfFalse b, P, (T⇩1#ST,LT)) = (ST,LT)"
| eff⇩i_Invoke:
"eff⇩i (Invoke M n, P, (ST,LT)) =
(let U = fst (snd (snd (method P (the (class_type_of' (ST ! n))) M)))
in (U # drop (n+1) ST, LT))"
| eff⇩i_Goto:
"eff⇩i (Goto n, P, s) = s"
| eff⇩i_MEnter:
"eff⇩i (MEnter, P, (T1#ST,LT)) = (ST,LT)"
| eff⇩i_MExit:
"eff⇩i (MExit, P, (T1#ST,LT)) = (ST,LT)"
fun is_relevant_class :: "'addr instr ⇒ 'm prog ⇒ cname ⇒ bool"
where
rel_Getfield:
"is_relevant_class (Getfield F D) = (λP C. P ⊢ NullPointer ≼⇧* C)"
| rel_Putfield:
"is_relevant_class (Putfield F D) = (λP C. P ⊢ NullPointer ≼⇧* C)"
| rel_CAS:
"is_relevant_class (CAS F D) = (λP C. P ⊢ NullPointer ≼⇧* C)"
| rel_Checcast:
"is_relevant_class (Checkcast T) = (λP C. P ⊢ ClassCast ≼⇧* C)"
| rel_New:
"is_relevant_class (New D) = (λP C. P ⊢ OutOfMemory ≼⇧* C)"
| rel_Throw:
"is_relevant_class ThrowExc = (λP C. True)"
| rel_Invoke:
"is_relevant_class (Invoke M n) = (λP C. True)"
| rel_NewArray:
"is_relevant_class (NewArray T) = (λP C. (P ⊢ OutOfMemory ≼⇧* C) ∨ (P ⊢ NegativeArraySize ≼⇧* C))"
| rel_ALoad:
"is_relevant_class ALoad = (λP C. P ⊢ ArrayIndexOutOfBounds ≼⇧* C ∨ P ⊢ NullPointer ≼⇧* C)"
| rel_AStore:
"is_relevant_class AStore = (λP C. P ⊢ ArrayIndexOutOfBounds ≼⇧* C ∨ P ⊢ ArrayStore ≼⇧* C ∨ P ⊢ NullPointer ≼⇧* C)"
| rel_ALength:
"is_relevant_class ALength = (λP C. P ⊢ NullPointer ≼⇧* C)"
| rel_MEnter:
"is_relevant_class MEnter = (λP C. P ⊢ IllegalMonitorState ≼⇧* C ∨ P ⊢ NullPointer ≼⇧* C)"
| rel_MExit:
"is_relevant_class MExit = (λP C. P ⊢ IllegalMonitorState ≼⇧* C ∨ P ⊢ NullPointer ≼⇧* C)"
| rel_BinOp:
"is_relevant_class (BinOpInstr bop) = binop_relevant_class bop"
| rel_default:
"is_relevant_class i = (λP C. False)"
definition is_relevant_entry :: "'m prog ⇒ 'addr instr ⇒ pc ⇒ ex_entry ⇒ bool"
where
"is_relevant_entry P i pc e ≡
let (f,t,C,h,d) = e
in (case C of None ⇒ True | ⌊C'⌋ ⇒ is_relevant_class i P C') ∧ pc ∈ {f..<t}"
definition relevant_entries :: "'m prog ⇒ 'addr instr ⇒ pc ⇒ ex_table ⇒ ex_table"
where
"relevant_entries P i pc ≡ filter (is_relevant_entry P i pc)"
definition xcpt_eff :: "'addr instr ⇒ 'm prog ⇒ pc ⇒ ty⇩i ⇒ ex_table ⇒ (pc × ty⇩i') list"
where
"xcpt_eff i P pc τ et ≡ let (ST,LT) = τ in
map (λ(f,t,C,h,d). (h, Some ((case C of None ⇒ Class Throwable | Some C' ⇒ Class C')#drop (size ST - d) ST, LT))) (relevant_entries P i pc et)"
definition norm_eff :: "'addr instr ⇒ 'm prog ⇒ nat ⇒ ty⇩i ⇒ (pc × ty⇩i') list"
where "norm_eff i P pc τ ≡ map (λpc'. (pc',Some (eff⇩i (i,P,τ)))) (succs i τ pc)"
definition eff :: "'addr instr ⇒ 'm prog ⇒ pc ⇒ ex_table ⇒ ty⇩i' ⇒ (pc × ty⇩i') list"
where
"eff i P pc et t ≡
case t of
None ⇒ []
| Some τ ⇒ (norm_eff i P pc τ) @ (xcpt_eff i P pc τ et)"
lemma eff_None:
"eff i P pc xt None = []"
by (simp add: eff_def)
lemma eff_Some:
"eff i P pc xt (Some τ) = norm_eff i P pc τ @ xcpt_eff i P pc τ xt"
by (simp add: eff_def)
text "Conditions under which eff is applicable:"
fun app⇩i :: "'addr instr × 'm prog × pc × nat × ty × ty⇩i ⇒ bool"
where
app⇩i_Load:
"app⇩i (Load n, P, pc, mxs, T⇩r, (ST,LT)) =
(n < length LT ∧ LT ! n ≠ Err ∧ length ST < mxs)"
| app⇩i_Store:
"app⇩i (Store n, P, pc, mxs, T⇩r, (T#ST, LT)) =
(n < length LT)"
| app⇩i_Push:
"app⇩i (Push v, P, pc, mxs, T⇩r, (ST,LT)) =
(length ST < mxs ∧ typeof v ≠ None)"
| app⇩i_Getfield:
"app⇩i (Getfield F C, P, pc, mxs, T⇩r, (T#ST, LT)) =
(∃T⇩f fm. P ⊢ C sees F:T⇩f (fm) in C ∧ P ⊢ T ≤ Class C)"
| app⇩i_Putfield:
"app⇩i (Putfield F C, P, pc, mxs, T⇩r, (T⇩1#T⇩2#ST, LT)) =
(∃T⇩f fm. P ⊢ C sees F:T⇩f (fm) in C ∧ P ⊢ T⇩2 ≤ (Class C) ∧ P ⊢ T⇩1 ≤ T⇩f)"
| app⇩i_CAS:
"app⇩i (CAS F C, P, pc, mxs, T⇩r, (T⇩3#T⇩2#T⇩1#ST, LT)) =
(∃T⇩f fm. P ⊢ C sees F:T⇩f (fm) in C ∧ volatile fm ∧ P ⊢ T⇩1 ≤ Class C ∧ P ⊢ T⇩2 ≤ T⇩f ∧ P ⊢ T⇩3 ≤ T⇩f)"
| app⇩i_New:
"app⇩i (New C, P, pc, mxs, T⇩r, (ST,LT)) =
(is_class P C ∧ length ST < mxs)"
| app⇩i_NewArray:
"app⇩i (NewArray Ty, P, pc, mxs, T⇩r, (Integer#ST,LT)) =
is_type P (Ty⌊⌉)"
| app⇩i_ALoad:
"app⇩i (ALoad, P, pc, mxs, T⇩r, (T1#T2#ST,LT)) =
(T1 = Integer ∧ (T2 ≠ NT ⟶ (∃Ty. T2 = Ty⌊⌉)))"
| app⇩i_AStore:
"app⇩i (AStore, P, pc, mxs, T⇩r, (T1#T2#T3#ST,LT)) =
(T2 = Integer ∧ (T3 ≠ NT ⟶ (∃Ty. T3 = Ty⌊⌉)))"
| app⇩i_ALength:
"app⇩i (ALength, P, pc, mxs, T⇩r, (T1#ST,LT)) =
(T1 = NT ∨ (∃Ty. T1 = Ty⌊⌉))"
| app⇩i_Checkcast:
"app⇩i (Checkcast Ty, P, pc, mxs, T⇩r, (T#ST,LT)) =
(is_type P Ty)"
| app⇩i_Instanceof:
"app⇩i (Instanceof Ty, P, pc, mxs, T⇩r, (T#ST,LT)) =
(is_type P Ty ∧ is_refT T)"
| app⇩i_Pop:
"app⇩i (Pop, P, pc, mxs, T⇩r, (T#ST,LT)) =
True"
| app⇩i_Dup:
"app⇩i (Dup, P, pc, mxs, T⇩r, (T#ST,LT)) =
(Suc (length ST) < mxs)"
| app⇩i_Swap:
"app⇩i (Swap, P, pc, mxs, T⇩r, (T1#T2#ST,LT)) = True"
| app⇩i_BinOpInstr:
"app⇩i (BinOpInstr bop, P, pc, mxs, T⇩r, (T2#T1#ST,LT)) = (∃T. P ⊢ T1«bop»T2 : T)"
| app⇩i_IfFalse:
"app⇩i (IfFalse b, P, pc, mxs, T⇩r, (Boolean#ST,LT)) =
(0 ≤ int pc + b)"
| app⇩i_Goto:
"app⇩i (Goto b, P, pc, mxs, T⇩r, s) = (0 ≤ int pc + b)"
| app⇩i_Return:
"app⇩i (Return, P, pc, mxs, T⇩r, (T#ST,LT)) = (P ⊢ T ≤ T⇩r)"
| app⇩i_Throw:
"app⇩i (ThrowExc, P, pc, mxs, T⇩r, (T#ST,LT)) =
(T = NT ∨ (∃C. T = Class C ∧ P ⊢ C ≼⇧* Throwable))"
| app⇩i_Invoke:
"app⇩i (Invoke M n, P, pc, mxs, T⇩r, (ST,LT)) =
(n < length ST ∧
(ST!n ≠ NT ⟶
(∃C D Ts T m. class_type_of' (ST ! n) = ⌊C⌋ ∧ P ⊢ C sees M:Ts → T = m in D ∧ P ⊢ rev (take n ST) [≤] Ts)))"
| app⇩i_MEnter:
"app⇩i (MEnter,P, pc,mxs,T⇩r,(T#ST,LT)) = (is_refT T)"
| app⇩i_MExit:
"app⇩i (MExit,P, pc,mxs,T⇩r,(T#ST,LT)) = (is_refT T)"
| app⇩i_default:
"app⇩i (i,P, pc,mxs,T⇩r,s) = False"
definition xcpt_app :: "'addr instr ⇒ 'm prog ⇒ pc ⇒ nat ⇒ ex_table ⇒ ty⇩i ⇒ bool"
where
"xcpt_app i P pc mxs xt τ ≡ ∀(f,t,C,h,d) ∈ set (relevant_entries P i pc xt). (case C of None ⇒ True | Some C' ⇒ is_class P C') ∧ d ≤ size (fst τ) ∧ d < mxs"
definition app :: "'addr instr ⇒ 'm prog ⇒ nat ⇒ ty ⇒ nat ⇒ nat ⇒ ex_table ⇒ ty⇩i' ⇒ bool"
where
"app i P mxs T⇩r pc mpc xt t ≡ case t of None ⇒ True | Some τ ⇒
app⇩i (i,P,pc,mxs,T⇩r,τ) ∧ xcpt_app i P pc mxs xt τ ∧
(∀(pc',τ') ∈ set (eff i P pc xt t). pc' < mpc)"
lemma app_Some:
"app i P mxs T⇩r pc mpc xt (Some τ) =
(app⇩i (i,P,pc,mxs,T⇩r,τ) ∧ xcpt_app i P pc mxs xt τ ∧
(∀(pc',s') ∈ set (eff i P pc xt (Some τ)). pc' < mpc))"
by (simp add: app_def)
locale eff = jvm_method +
fixes eff⇩i and app⇩i and eff and app
fixes norm_eff and xcpt_app and xcpt_eff
fixes mpc
defines "mpc ≡ size is"
defines "eff⇩i i τ ≡ Effect.eff⇩i (i,P,τ)"
notes eff⇩i_simps [simp] = Effect.eff⇩i.simps [where P = P, folded eff⇩i_def]
defines "app⇩i i pc τ ≡ Effect.app⇩i (i, P, pc, mxs, T⇩r, τ)"
notes app⇩i_simps [simp] = Effect.app⇩i.simps [where P=